Apophis
view release on metacpan or search on metacpan
/*
* Apophis.xs - Content-addressable storage with deterministic UUID v5
*
* Named after Apophis, the Egyptian serpent of chaos — here tamed
* to bring order to content through deterministic hashing.
*
* 100% XS: all logic in C, Perl layer is just XSLoader.
* Uses Horus library for RFC 9562 UUID v5 (SHA-1 namespace) generation.
*/
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#include <sys/stat.h>
#include <errno.h>
#ifndef _WIN32
# include <unistd.h>
#else
# include <io.h>
# include <direct.h>
# include <windows.h> /* MoveFileEx; perl.h has it already, this is a guard */
#endif
/*
* Windows compatibility:
* perl.h on threaded Windows redefines mkdir, stat, unlink etc. as macros
* requiring the interpreter context (my_perl). Our static C helper functions
* don't have pTHX, so we undo those overrides and use the real libc calls.
*/
#ifdef WIN32
# undef mkdir
# undef stat
# undef unlink
# undef rename
# undef open
# undef close
# undef read
# undef write
/* Windows mkdir takes only one arg */
# define apophis_mkdir(p, m) _mkdir(p)
/*
* Stat_t is struct w32_stat, the layout perl's own stat() fills in - but
* that stat() is the macro undef'd just above, so what is left is the CRT
* one, which writes a differently shaped struct. Pair the call and the
* type instead: _stat64 keeps st_size 64 bit, which the CRT's struct stat
* does not on Win64.
*/
# define apophis_stat_t struct _stat64
# define apophis_stat(p, b) _stat64((p), (b))
#else
# define apophis_mkdir(p, m) mkdir(p, m)
# define apophis_stat_t struct stat
# define apophis_stat(p, b) stat((p), (b))
#endif
/*
* The CRT rename() refuses a destination that already exists, so the second
* store of the same content with metadata could not replace its sidecar.
* MoveFileEx replaces, and stays atomic.
*/
static int
apophis_rename(const char *from, const char *to)
{
#ifdef WIN32
if (MoveFileExA(from, to, MOVEFILE_REPLACE_EXISTING))
return 0;
errno = EACCES;
return -1;
#else
return rename(from, to);
#endif
}
/* Horus UUID library - pure C, no Perl deps */
#define HORUS_FATAL(msg) croak("%s", (msg))
#include "horus_core.h"
/* ------------------------------------------------------------------ */
/* Constants */
/* ------------------------------------------------------------------ */
#define APOPHIS_STREAM_BUF 65536 /* 64KB read chunks for streaming */
#define APOPHIS_PATH_MAX 4096
/* ------------------------------------------------------------------ */
/* Internal: namespace UUID generation */
/* ------------------------------------------------------------------ */
/* Derive a namespace UUID from a human-readable string via v5(DNS, name) */
static void
apophis_derive_namespace(unsigned char *ns_out,
const char *name, STRLEN name_len)
{
horus_uuid_v5(ns_out, HORUS_NS_DNS,
(const unsigned char *)name, (size_t)name_len);
}
/* Format 16-byte UUID binary to 36-char string SV */
static SV *
apophis_uuid_to_sv(pTHX_ const unsigned char *uuid)
{
char buf[HORUS_FMT_STR_LEN + 1];
horus_format_uuid(buf, uuid, HORUS_FMT_STR);
return newSVpvn(buf, HORUS_FMT_STR_LEN);
}
/* ------------------------------------------------------------------ */
/* Internal: content identification */
/* ------------------------------------------------------------------ */
/* Identify in-memory content: v5(namespace, content) */
static void
apophis_identify_content(unsigned char *uuid_out,
const unsigned char *ns_bytes,
const char *content, STRLEN content_len)
{
horus_uuid_v5(uuid_out, ns_bytes,
(const unsigned char *)content, (size_t)content_len);
}
/* Identify via streaming SHA-1 — O(1) memory */
static void
apophis_identify_stream(pTHX_ unsigned char *uuid_out,
const unsigned char *ns_bytes,
PerlIO *fh)
{
horus_sha1_ctx ctx;
unsigned char buf[APOPHIS_STREAM_BUF];
unsigned char digest[20];
SSize_t nread;
{
return snprintf(out, out_size, "%.*s.meta",
content_path_len, content_path);
}
/* ------------------------------------------------------------------ */
/* Internal: recursive mkdir */
/* ------------------------------------------------------------------ */
static void
apophis_mkdir_p(const char *path)
{
char buf[APOPHIS_PATH_MAX];
char *p;
size_t len;
len = strlen(path);
if (len >= sizeof(buf))
croak("Apophis: path too long");
memcpy(buf, path, len + 1);
for (p = buf + 1; *p; p++) {
if (*p == '/') {
*p = '\0';
if (apophis_mkdir(buf, 0777) != 0 && errno != EEXIST) {
croak("Apophis: cannot create directory '%s': %s",
buf, strerror(errno));
}
*p = '/';
}
}
/* Final component */
if (apophis_mkdir(buf, 0777) != 0 && errno != EEXIST) {
croak("Apophis: cannot create directory '%s': %s",
buf, strerror(errno));
}
}
/* Ensure parent directory of a file path exists */
static void
apophis_ensure_parent_dir(const char *file_path)
{
char buf[APOPHIS_PATH_MAX];
char *last_slash;
size_t len;
len = strlen(file_path);
if (len >= sizeof(buf))
croak("Apophis: path too long");
memcpy(buf, file_path, len + 1);
last_slash = strrchr(buf, '/');
if (last_slash) {
*last_slash = '\0';
apophis_mkdir_p(buf);
}
}
/* ------------------------------------------------------------------ */
/* Internal: atomic file write (temp + rename) */
/* ------------------------------------------------------------------ */
static void
apophis_atomic_write(pTHX_ const char *path,
const char *content, STRLEN content_len)
{
char tmp_path[APOPHIS_PATH_MAX];
PerlIO *fh;
SSize_t written;
snprintf(tmp_path, sizeof(tmp_path), "%s.tmp.%d",
path, (int)getpid());
fh = PerlIO_open(tmp_path, "wb");
if (!fh)
croak("Apophis: cannot write '%s': %s", tmp_path, strerror(errno));
written = PerlIO_write(fh, content, content_len);
PerlIO_close(fh);
if (written != (SSize_t)content_len) {
unlink(tmp_path);
croak("Apophis: short write to '%s'", tmp_path);
}
if (apophis_rename(tmp_path, path) != 0) {
unlink(tmp_path);
croak("Apophis: cannot rename '%s' -> '%s': %s",
tmp_path, path, strerror(errno));
}
}
/* ------------------------------------------------------------------ */
/* Internal: metadata sidecar (key=value\n format) */
/* ------------------------------------------------------------------ */
static void
apophis_meta_write(pTHX_ const char *meta_path, HV *meta)
{
PerlIO *fh;
HE *entry;
char tmp_path[APOPHIS_PATH_MAX];
snprintf(tmp_path, sizeof(tmp_path), "%s.tmp.%d",
meta_path, (int)getpid());
fh = PerlIO_open(tmp_path, "w");
if (!fh)
croak("Apophis: cannot write metadata '%s': %s",
tmp_path, strerror(errno));
hv_iterinit(meta);
while ((entry = hv_iternext(meta))) {
SV *val = hv_iterval(meta, entry);
I32 klen;
const char *key = hv_iterkey(entry, &klen);
STRLEN vlen;
const char *vstr = SvPV(val, vlen);
PerlIO_write(fh, key, (SSize_t)klen);
PerlIO_write(fh, "=", 1);
PerlIO_write(fh, vstr, (SSize_t)vlen);
PerlIO_write(fh, "\n", 1);
}
PerlIO_close(fh);
if (apophis_rename(tmp_path, meta_path) != 0) {
unlink(tmp_path);
croak("Apophis: cannot rename metadata '%s': %s",
tmp_path, strerror(errno));
}
}
static HV *
apophis_meta_read(pTHX_ const char *meta_path)
{
PerlIO *fh;
HV *meta;
apophis_stat_t st;
char *buf, *p, *end;
SSize_t nread;
if (apophis_stat(meta_path, &st) != 0) return NULL;
fh = PerlIO_open(meta_path, "r");
if (!fh) return NULL;
buf = (char *)malloc((size_t)st.st_size + 1);
if (!buf) { PerlIO_close(fh); return NULL; }
nread = PerlIO_read(fh, buf, (Size_t)st.st_size);
PerlIO_close(fh);
if (nread < 0) { free(buf); return NULL; }
buf[nread] = '\0';
meta = newHV();
p = buf;
end = buf + nread;
while (p < end) {
char *line_end = strchr(p, '\n');
char *eq;
if (!line_end) line_end = end;
eq = (char *)memchr(p, '=', (size_t)(line_end - p));
if (eq) {
hv_store(meta, p, (I32)(eq - p),
newSVpvn(eq + 1, (STRLEN)(line_end - eq - 1)), 0);
}
p = line_end + 1;
}
free(buf);
return meta;
}
/* ------------------------------------------------------------------ */
/* Internal: object field accessors */
/* ------------------------------------------------------------------ */
/* Get the 16-byte namespace bytes from the object */
static const unsigned char *
apophis_get_ns(pTHX_ HV *self)
{
SV **svp = hv_fetchs(self, "_ns_bytes", 0);
if (!svp || !SvOK(*svp))
croak("Apophis: object has no namespace (not properly constructed)");
#if PERL_VERSION >= 14
static XOP apophis_xop_identify;
static XOP apophis_xop_store;
static XOP apophis_xop_exists;
static XOP apophis_xop_fetch;
static XOP apophis_xop_verify;
static XOP apophis_xop_remove;
#endif
/*
* pp_apophis_identify - Custom op: content → UUID v5 string
*
* Stack input: self_sv, content_ref_sv
* Stack output: uuid_string_sv
*
* Fuses: namespace extraction + SHA-1 + v5 stamp + format
* Zero intermediate SVs, no method dispatch overhead.
*/
static OP *
pp_apophis_identify(pTHX) {
dSP;
SV *content_ref_sv = POPs;
SV *self_sv = POPs;
HV *hv;
const unsigned char *ns;
SV *content_sv;
const char *content;
STRLEN content_len;
unsigned char uuid[16];
if (!sv_isobject(self_sv))
croak("Apophis: pp_identify: not an object");
hv = (HV *)SvRV(self_sv);
ns = apophis_get_ns(aTHX_ hv);
if (!SvROK(content_ref_sv))
croak("Apophis: pp_identify: argument must be a scalar reference");
content_sv = SvRV(content_ref_sv);
content = SvPV(content_sv, content_len);
apophis_identify_content(uuid, ns, content, content_len);
EXTEND(SP, 1);
PUSHs(sv_2mortal(apophis_uuid_to_sv(aTHX_ uuid)));
PUTBACK;
return NORMAL;
}
/*
* pp_apophis_store - Custom op: fused identify + mkdir + atomic write
*
* Stack input: self_sv, content_ref_sv
* Stack output: uuid_string_sv
*
* Fuses the entire store pipeline into a single op:
* 1. Extract namespace bytes from object
* 2. SHA-1 hash content → UUID v5
* 3. Compute 2-level sharded path
* 4. stat() for CAS dedup check
* 5. mkdir -p parent directories
* 6. Atomic write (temp + rename)
* 7. Format and return UUID string
*/
static OP *
pp_apophis_store(pTHX) {
dSP;
SV *content_ref_sv = POPs;
SV *self_sv = POPs;
HV *hv;
const unsigned char *ns;
SV *content_sv;
const char *content;
STRLEN content_len;
unsigned char uuid[16];
char id_str[HORUS_FMT_STR_LEN + 1];
const char *store_dir;
STRLEN store_dir_len;
char path[APOPHIS_PATH_MAX];
apophis_stat_t st;
if (!sv_isobject(self_sv))
croak("Apophis: pp_store: not an object");
hv = (HV *)SvRV(self_sv);
ns = apophis_get_ns(aTHX_ hv);
if (!SvROK(content_ref_sv))
croak("Apophis: pp_store: argument must be a scalar reference");
content_sv = SvRV(content_ref_sv);
content = SvPV(content_sv, content_len);
/* Identify */
apophis_identify_content(uuid, ns, content, content_len);
horus_format_uuid(id_str, uuid, HORUS_FMT_STR);
/* Get store_dir from object */
store_dir = apophis_get_store_dir(aTHX_ hv, NULL, &store_dir_len);
/* Build sharded path */
apophis_build_path(path, sizeof(path),
store_dir, store_dir_len,
id_str, HORUS_FMT_STR_LEN);
/* CAS dedup: only write if not already stored */
if (apophis_stat(path, &st) != 0) {
apophis_ensure_parent_dir(path);
apophis_atomic_write(aTHX_ path, content, content_len);
}
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSVpvn(id_str, HORUS_FMT_STR_LEN)));
PUTBACK;
return NORMAL;
}
/*
* pp_apophis_exists - Custom op: UUID → boolean existence check
*
* Stack input: self_sv, id_sv
* Stack output: bool_sv
*
* Fuses: path computation + stat() into a single op.
( run in 0.905 second using v1.01-cache-2.11-cpan-a49fcb8fa48 )