fix: backup/restore field mismatch, tx-cache-key collision, tempid race, segment comparison, content hash, read timeout
ober
b3f26163b72a8295fd9fe5c93e4d9838529dcf52
--- a/lib/jerboa-db/backup.ss +++ b/lib/jerboa-db/backup.ss @@ -29,6 +29,8 @@ (jerboa-db index protocol) (jerboa-db index memory) (jerboa-db history) + (jerboa-db fulltext) + (jerboa-db stats) (except (jerboa-db core) log)) ;; ---- Magic header ---- @@ -66,7 +68,8 @@ ;; Convert schema registry to closed plain data for storage portability. (def (schema->plist schema) - ;; Returns a list of (ident id vtype card unique index? comp? doc no-hist?) + ;; Returns a list of + ;; (ident id vtype card unique index? comp? doc no-hist? tuple-attrs fulltext?) (map (lambda (attr) (list (db-attribute-ident attr) (db-attribute-id attr) @@ -76,7 +79,9 @@ (db-attribute-index? attr) (db-attribute-is-component? attr) (db-attribute-doc attr) - (db-attribute-no-history? attr))) + (db-attribute-no-history? attr) + (db-attribute-tuple-attrs attr) + (db-attribute-fulltext? attr))) (schema-all-attributes schema))) (def (plist->schema plist) @@ -93,11 +98,14 @@ [idx? (list-ref entry 5)] [comp? (list-ref entry 6)] [doc (list-ref entry 7)] - [no-hist (list-ref entry 8)]) + [no-hist (list-ref entry 8)] + [tup (list-ref entry 9)] + [ft? (list-ref entry 10)]) ;; Only install user attributes; system ones are already bootstrapped (when (>= id +first-user-attr-id+) (let ([attr (make-db-attribute - ident id vtype card unique idx? comp? doc no-hist)]) + ident id vtype card unique idx? comp? doc no-hist + tup ft?)]) (schema-install-attribute! reg attr))))) plist) reg)) @@ -110,7 +118,7 @@ (boolean? (list-ref entry 4)))) (def (valid-backup-schema-entry? entry) - (and (equal? (bounded-proper-list-length entry 10) 9) + (and (equal? (bounded-proper-list-length entry 12) 11) (symbol? (list-ref entry 0)) (integer? (list-ref entry 1)) (>= (list-ref entry 1) 0) @@ -122,7 +130,10 @@ (boolean? (list-ref entry 6)) (let ([doc (list-ref entry 7)]) (or (not doc) (string? doc))) - (boolean? (list-ref entry 8)))) + (boolean? (list-ref entry 8)) + (let ([tup (list-ref entry 9)]) + (or (not tup) (and (list? tup) (andmap symbol? tup)))) + (boolean? (list-ref entry 10)))) (def (bounded-proper-list-length value maximum) ;; Returns the length or #f. Unlike an unbounded `length`, this also @@ -294,42 +305,54 @@ [aevt (index-set-aevt indices)] [avet (index-set-avet indices)] [vaet (index-set-vaet indices)]) - ;; Insert each datom into appropriate indices - (for-each - (lambda (entry) - (let* ([e (list-ref entry 0)] - [a (list-ref entry 1)] - [v (list-ref entry 2)] - [tx (list-ref entry 3)] - [added (list-ref entry 4)] - [d (make-datom e a v tx added)]) - ;; Always insert into EAVT and AEVT - (dbi-add! eavt d) - (dbi-add! aevt d) - ;; Insert into AVET if attribute is indexed - (let ([attr (schema-lookup-by-id schema a)]) - (when (and attr (indexed-attr? attr)) - (dbi-add! avet d)) - ;; Insert into VAET if ref type - (when (and attr (ref-type? attr)) - (dbi-add! vaet d))))) - datom-list) - ;; Compute next-eid = max entity id + 1 - (let ([max-eid (fold-left - (lambda (acc entry) (max acc (list-ref entry 0))) - +first-user-attr-id+ - datom-list)]) - ;; Build the initial db-value - (let* ([initial-db (make-db-value basis-tx indices schema #f #f #f #f)] - [conn (make-connection - initial-db - (list (+ max-eid 1)) - '() - (new-db-cache 10000) - ":memory:" - #f ;; db-handles - #f ;; fulltext-index - #f)]) - conn)))))) + ;; Insert each datom into appropriate indices, collecting the + ;; replayed datom records so we can rebuild live stats and the + ;; fulltext index below. + (let ([replayed '()]) + (for-each + (lambda (entry) + (let* ([e (list-ref entry 0)] + [a (list-ref entry 1)] + [v (list-ref entry 2)] + [tx (list-ref entry 3)] + [added (list-ref entry 4)] + [d (make-datom e a v tx added)]) + (set! replayed (cons d replayed)) + ;; Always insert into EAVT and AEVT + (dbi-add! eavt d) + (dbi-add! aevt d) + ;; Insert into AVET if attribute is indexed + (let ([attr (schema-lookup-by-id schema a)]) + (when (and attr (indexed-attr? attr)) + (dbi-add! avet d)) + ;; Insert into VAET if ref type + (when (and attr (ref-type? attr)) + (dbi-add! vaet d))))) + datom-list) + ;; Compute next-eid = max entity id + 1 + (let ([max-eid (fold-left + (lambda (acc entry) (max acc (list-ref entry 0))) + +first-user-attr-id+ + datom-list)] + [replayed (reverse replayed)]) + ;; Rebuild live per-attribute stats and the fulltext index from + ;; the replayed datoms so the restored connection behaves like + ;; one produced by `connect` (callers may invoke db-stats or + ;; fulltext-search on it without crashing). + (let ([stats (make-db-stats)] + [ft-idx (make-fulltext-index)]) + (db-stats-update! stats replayed) + (fulltext-index-datoms! ft-idx schema replayed) + (let* ([initial-db (make-db-value basis-tx indices schema #f #f #f stats)] + [conn (make-connection + initial-db + (list (+ max-eid 1)) + '() + (new-db-cache 10000) + ":memory:" + #f ;; db-handles + ft-idx ;; fulltext-index + stats)]) ;; db-stats + conn)))))))) ) ;; end library --- a/lib/jerboa-db/encoding.ss +++ b/lib/jerboa-db/encoding.ss @@ -156,11 +156,15 @@ (bitwise-xor (bytevector-u8-ref bv i) #xFF))) (bytevector-ieee-double-ref out 0 (endianness big)))))) - ;; ---- Content hashing (FNV-1a 64-bit) ---- - ;; Used for variable-length values in index keys. - - (def +fnv-offset+ 14695981039346656037) - (def +fnv-prime+ 1099511628211) + ;; ---- Content hashing (SHA-256, truncated to 8 bytes) ---- + ;; Used for variable-length values in index keys and content-addressed + ;; storage. SHA-256 (FIPS 180-4) replaces the previous non-cryptographic + ;; FNV-1a 64-bit hash so content addressing is collision-resistant. + ;; + ;; The digest is truncated to 8 bytes to match the fixed 8-byte value-hash + ;; slot baked into the 28-byte index key format, the LevelDB range-scan + ;; sentinels, and the segment-store segment ids — widening it would corrupt + ;; key ordering and on-disk segment names. (def (content-hash-bytes value) (let* ([data (cond @@ -168,21 +172,11 @@ [(bytevector? value) value] [(symbol? value) (string->utf8 (symbol->string value))] [else (string->utf8 (format "~a" value))])] - [hash (fnv1a-64 data)] + [digest (sha256-bytevector data)] [bv (make-bytevector 8)]) - (bytevector-u64-set! bv 0 hash (endianness big)) + (bytevector-copy! digest 0 bv 0 8) bv)) - (def (fnv1a-64 data) - (let ([len (bytevector-length data)]) - (let loop ([i 0] [h +fnv-offset+]) - (if (>= i len) - (bitwise-and h #xFFFFFFFFFFFFFFFF) - (let* ([byte (bytevector-u8-ref data i)] - [h2 (bitwise-xor h byte)] - [h3 (bitwise-and (* h2 +fnv-prime+) #xFFFFFFFFFFFFFFFF)]) - (loop (+ i 1) h3)))))) - ;; ---- Full 28-byte index key construction ---- (def (encode-eavt-key e a v-hash tx added?) --- a/lib/jerboa-db/segment.ss +++ b/lib/jerboa-db/segment.ss @@ -147,19 +147,55 @@ (let ([n (seg-cnt s)]) (if (= n 0) 0 (/ (segment-sum-v s) n)))) + ;; ---- Total order over heterogeneous value columns ---- + ;; segment-min-v / segment-max-v may run over a 'mixed column holding + ;; incompatible types (strings, numbers, bools, ...). Plain < / > errors on + ;; such pairs, so order by a type rank first, then within each type. + (def (value-rank v) + (cond + [(boolean? v) 0] + [(number? v) 1] + [(string? v) 2] + [(symbol? v) 3] + [(bytevector? v) 4] + [else 5])) + + (def (bytevector<? a b) + (let ([n (min (bytevector-length a) (bytevector-length b))]) + (let loop ([i 0]) + (cond + [(= i n) (< (bytevector-length a) (bytevector-length b))] + [(< (bytevector-u8-ref a i) (bytevector-u8-ref b i)) #t] + [(> (bytevector-u8-ref a i) (bytevector-u8-ref b i)) #f] + [else (loop (+ i 1))])))) + + (def (value<? a b) + (let ([ra (value-rank a)] [rb (value-rank b)]) + (cond + [(< ra rb) #t] + [(> ra rb) #f] + [else + (case ra + [(0) (and (not a) b)] ;; #f < #t + [(1) (< a b)] ;; numeric + [(2) (string<? a b)] + [(3) (string<? (symbol->string a) (symbol->string b))] + [(4) (bytevector<? a b)] + [else #f])]))) ;; opaque: equal + (def (segment-min-v s) (let ([n (seg-cnt s)]) (if (= n 0) #f (let loop ([i 1] [m (segment-v s 0)]) - (if (= i n) m (loop (+ i 1) (let ([x (segment-v s i)]) (if (< x m) x m)))))))) + (if (= i n) m (loop (+ i 1) (let ([x (segment-v s i)]) (if (value<? x m) x m)))))))) (def (segment-max-v s) (let ([n (seg-cnt s)]) (if (= n 0) #f (let loop ([i 1] [m (segment-v s 0)]) - (if (= i n) m (loop (+ i 1) (let ([x (segment-v s i)]) (if (> x m) x m)))))))) + (if (= i n) m (loop (+ i 1) (let ([x (segment-v s i)]) (if (value<? m x) x m)))))))) ;; ---- Compact serialisation ---- ;; Columns are delta+zigzag+varint encoded (sorted runs shrink to ~1 byte), --- a/lib/jerboa-db/transport.ss +++ b/lib/jerboa-db/transport.ss @@ -259,6 +259,10 @@ ;; Writes a 4-byte big-endian uint32 length header followed by body bytes. (define +transport-max-frame-bytes+ (* 1024 1024)) (define +transport-max-frame-objects+ 100000) + ;; read-exactly retries zero-length reads every 10ms; bound the retries so a + ;; stalled peer that never delivers the promised bytes times out (~30s) + ;; instead of spinning forever. + (define +transport-read-max-retries+ 3000) (define +transport-auth-tag-bytes+ 32) (define +transport-auth-nonce-bytes+ 16) (define +transport-auth-min-key-bytes+ 32) @@ -525,7 +529,7 @@ ;; Reads a length-prefixed frame. Returns #f on EOF or truncated read. (define (read-exactly in-port n) (let ([buf (make-bytevector n)]) - (let loop ([offset 0]) + (let loop ([offset 0] [retries 0]) (if (= offset n) buf (let ([chunk (get-bytevector-n in-port (- n offset))]) @@ -533,11 +537,13 @@ [(and (bytevector? chunk) (> (bytevector-length chunk) 0)) (bytevector-copy! chunk 0 buf offset (bytevector-length chunk)) - (loop (+ offset (bytevector-length chunk)))] + (loop (+ offset (bytevector-length chunk)) 0)] [(and (bytevector? chunk) (= (bytevector-length chunk) 0)) + (when (>= retries +transport-read-max-retries+) + (error 'read-exactly "timeout waiting for frame bytes" n offset)) (sleep (chez-make-time 'time-duration 10000000 0)) - (loop offset)] + (loop offset (+ retries 1))] [else #f])))))) (define (read-frame in-port) --- a/lib/jerboa-db/tx.ss +++ b/lib/jerboa-db/tx.ss @@ -41,10 +41,12 @@ ;; Negative integers serve as temporary IDs within a transaction. (def tempid-counter 0) + (def tempid-mutex (make-mutex)) (def (tempid) - (set! tempid-counter (- tempid-counter 1)) - tempid-counter) + (with-mutex tempid-mutex + (set! tempid-counter (- tempid-counter 1)) + tempid-counter)) (def (tempid? x) (and (integer? x) (< x 0))) @@ -220,14 +222,15 @@ eid (datom-v cur) new-ident)))))) ;; Per-transaction value cache: O(1) lookup for cardinality/one checks. - ;; Keyed by a composite fixnum (eid * 256 + aid) — no allocation per lookup. - ;; Assumes aid < 256 (generous: schemas typically have < 100 attributes). + ;; Keyed by a (eid . aid) pair in an equal?-hashtable so attribute ids are + ;; unbounded — a packed fixnum key such as eid*256+aid collides once a + ;; schema defines its 256th attribute. ;; Updated by every emit-datom! call. ;; This avoids the EAVT index scan for freshly-allocated entities. - (define tx-val-cache (make-eqv-hashtable)) + (define tx-val-cache (make-hashtable equal-hash equal?)) (define *cache-miss* (list 'miss)) ;; unique sentinel - (define (tx-cache-key eid aid) (+ (* eid 256) aid)) ;; allocation-free + (define (tx-cache-key eid aid) (cons eid aid)) ;; Returns a datom if (eid,aid) has a live assertion in this tx, else #f. (define (tx-current-value eid aid)