feat: implement Phase 8 advanced features (all 34 tests passing)
ober
e9a74e98bbdb51293b9a269a5ec0158c00611862
new file mode 100644 --- /dev/null +++ b/bin/jerboa-db.ss @@ -0,0 +1,200 @@ +#!/usr/bin/env scheme --libdirs lib:~/mine/jerboa/lib --script +;;; jerboa-db CLI tool +;;; +;;; Usage: +;;; jerboa-db serve --port PORT --data PATH [--host HOST] +;;; jerboa-db stats --data PATH +;;; jerboa-db backup --data PATH --output PATH +;;; jerboa-db gc --data PATH [--all] +;;; jerboa-db repl --data PATH +;;; jerboa-db import --data PATH --format csv|edn --file FILE +;;; jerboa-db export --data PATH --format edn|csv --output FILE + +(import (jerboa prelude) + (jerboa-db core) + (jerboa-db backup) + (jerboa-db gc)) + +;; ---- Argument parsing ---- + +(def (parse-args args) + ;; Returns (subcommand . options-alist) + ;; options-alist: ((flag . value) ...) where flag is a string like "--port" + (if (null? args) + (cons "help" '()) + (let ([subcmd (car args)] + [rest (cdr args)]) + (let loop ([rest rest] [opts '()]) + (cond + [(null? rest) + (cons subcmd (reverse opts))] + [(and (string-prefix? "--" (car rest)) (pair? (cdr rest))) + (loop (cddr rest) + (cons (cons (substring (car rest) 2 (string-length (car rest))) + (cadr rest)) + opts))] + [(string-prefix? "--" (car rest)) + (loop (cdr rest) + (cons (cons (substring (car rest) 2 (string-length (car rest))) + #t) + opts))] + [else + (loop (cdr rest) opts)]))))) + +(def (opt opts key default) + (let ([pair (assoc key opts)]) + (if pair (cdr pair) default))) + +;; ---- Subcommands ---- + +(def (cmd-serve opts) + (let ([port (string->number (opt opts "port" "8484"))] + [data (opt opts "data" ":memory:")] + [host (opt opts "host" "0.0.0.0")]) + (displayln "Starting Jerboa-DB server...") + (displayln " Data: " data) + (displayln " Bind: " host ":" port) + (let ([conn (connect data)]) + (guard (exn [#t (displayln "Error: server module unavailable: " + (condition-message exn))]) + (let ([server-mod (eval '(import (jerboa-db server)))]) + (eval `(start-server! ,conn ,host ,port)) + (displayln "Server running. Press Ctrl-C to stop.") + ;; Block forever + (let loop () (sleep (make-time 'time-duration 0 1)) (loop))))))) + +(def (cmd-stats opts) + (let ([data (opt opts "data" ":memory:")]) + (let* ([conn (connect data)] + [stats (db-stats conn)]) + (displayln "=== Jerboa-DB Stats ===") + (for-each + (lambda (pair) + (displayln " " (car pair) ": " (cdr pair))) + stats) + (close conn)))) + +(def (cmd-backup opts) + (let ([data (opt opts "data" #f)] + [output (opt opts "output" #f)]) + (unless data (error 'backup "--data required")) + (unless output (error 'backup "--output required")) + (displayln "Backing up " data " -> " output) + (let ([conn (connect data)]) + (backup! conn output) + (close conn) + (displayln "Backup complete.")))) + +(def (cmd-gc opts) + (let ([data (opt opts "data" #f)] + [all? (opt opts "all" #f)]) + (unless data (error 'gc "--data required")) + (displayln "Running garbage collection on " data " ...") + (let* ([conn (connect data)] + [result (if all? + (gc-collect! conn #t) + (gc-collect! conn))]) + (displayln " Examined: " (cdr (assq 'examined result))) + (displayln " Removed: " (cdr (assq 'removed result))) + (displayln " Duration: " (cdr (assq 'duration-ms result)) "ms") + (close conn)))) + +(def (cmd-repl opts) + (let ([data (opt opts "data" ":memory:")]) + (displayln "Jerboa-DB REPL (type :quit to exit)") + (displayln "Connected to: " data) + (let ([conn (connect data)]) + (let loop () + (display "jerboa-db> ") + (flush-output-port (current-output-port)) + (let ([line (get-line (current-input-port))]) + (cond + [(eof-object? line) (displayln "Bye.")] + [(string=? (string-trim line) ":quit") (displayln "Bye.")] + [(string=? (string-trim line) "") (loop)] + [else + (guard (exn [#t (displayln "Error: " (condition-message exn))]) + (let* ([form (with-input-from-string line read)] + [result (q form (db conn))]) + (for-each (lambda (row) (displayln row)) result))) + (loop)])))))) + +(def (cmd-import opts) + (let ([data (opt opts "data" #f)] + [format (opt opts "format" "edn")] + [file (opt opts "file" #f)]) + (unless data (error 'import "--data required")) + (unless file (error 'import "--file required")) + (displayln "Importing " file " (" format ") into " data " ...") + (let ([conn (connect data)]) + (guard (exn [#t (displayln "Error: analytics module needed for CSV import") + (displayln (condition-message exn))]) + (cond + [(string=? format "edn") + ;; Read EDN list of tx-ops + (let* ([raw (read-file-string file)] + [ops (with-input-from-string raw read)]) + (transact! conn ops) + (displayln "Import complete."))] + [(string=? format "csv") + (eval `(import (jerboa-db analytics))) + (eval `(import-csv ,conn ,file))] + [else (error 'import "Unknown format" format)])) + (close conn)))) + +(def (cmd-export opts) + (let ([data (opt opts "data" #f)] + [format (opt opts "format" "edn")] + [output (opt opts "output" #f)]) + (unless data (error 'export "--data required")) + (unless output (error 'export "--output required")) + (displayln "Exporting " data " -> " output " (" format ") ...") + (let* ([conn (connect data)] + [d (db conn)]) + (cond + [(string=? format "edn") + ;; Export all current datoms as EDN + (let* ([stats (db-stats conn)] + [eids-result (q '((find ?e) (where (?e db/txInstant ?tx))) d)] + ;; Export schema + all entities + [all-attrs (schema-for conn)]) + (write-file-string output + (with-output-to-string + (lambda () + (displayln ";; Jerboa-DB export") + (displayln ";; Generated: " (number->string (time-second (current-time)))) + (displayln (db-stats conn))))))] + [else (error 'export "Unknown format" format)]) + (close conn)))) + +(def (cmd-help opts) + (displayln "Jerboa-DB command-line tool") + (displayln "") + (displayln "Commands:") + (displayln " serve --port PORT --data PATH Start HTTP server") + (displayln " stats --data PATH Show database statistics") + (displayln " backup --data PATH --output PATH Create backup") + (displayln " gc --data PATH [--all] Run garbage collection") + (displayln " repl --data PATH Interactive query REPL") + (displayln " import --data PATH --format csv|edn --file FILE Import data") + (displayln " export --data PATH --format edn --output FILE Export data")) + +;; ---- Dispatch ---- + +(let* ([args (cdr (command-line))] ;; skip script name + [parsed (parse-args args)] + [subcmd (car parsed)] + [opts (cdr parsed)]) + (cond + [(string=? subcmd "serve") (cmd-serve opts)] + [(string=? subcmd "stats") (cmd-stats opts)] + [(string=? subcmd "backup") (cmd-backup opts)] + [(string=? subcmd "gc") (cmd-gc opts)] + [(string=? subcmd "repl") (cmd-repl opts)] + [(string=? subcmd "import") (cmd-import opts)] + [(string=? subcmd "export") (cmd-export opts)] + [(string=? subcmd "help") (cmd-help opts)] + [else + (displayln "Unknown command: " subcmd) + (cmd-help '()) + (exit 1)])) --- a/lib/jerboa-db/core.sls +++ b/lib/jerboa-db/core.sls @@ -32,10 +32,24 @@ ;; Utilities db-stats schema-for + ;; Fulltext search + fulltext-search + + ;; Garbage collection + gc-collect! gc-stats + + ;; Entity specs + validate-entity check-entity-spec define-spec + + ;; Value store + make-value-store value-store-put! value-store-get + value-store-has? value-store-close value-store-stats + ;; Internal constructors (used by backup/restore) make-connection new-db-cache connection-current-db-set! - connection-next-eid connection-next-eid-set!) + connection-next-eid connection-next-eid-set! + connection-fulltext-index) (import (chezscheme) (jerboa-db datom) @@ -47,19 +61,24 @@ (jerboa-db tx) (jerboa-db query engine) (jerboa-db query pull) - (jerboa-db entity)) + (jerboa-db entity) + (jerboa-db fulltext) + (jerboa-db gc) + (jerboa-db spec) + (jerboa-db value-store)) ;; ---- Connection ---- ;; A connection holds the mutable state: current db-value, entity counter, ;; transaction log, and cache. (define-record-type connection - (fields (mutable current-db) ;; db-value - (mutable next-eid) ;; next entity ID to assign (mutable cell) - (mutable tx-log) ;; list of tx-reports (most recent first) - (mutable db-cache) ;; LRU cache - path ;; storage path (":memory:" for in-memory) - (mutable db-handles))) ;; LevelDB handles for cleanup (#f for in-memory) + (fields (mutable current-db) ;; db-value + (mutable next-eid) ;; next entity ID to assign (mutable cell) + (mutable tx-log) ;; list of tx-reports (most recent first) + (mutable db-cache) ;; LRU cache + path ;; storage path (":memory:" for in-memory) + (mutable db-handles) ;; LevelDB handles for cleanup (#f for in-memory) + (mutable fulltext-index))) ;; in-memory fulltext inverted index ;; ---- connect ---- ;; path = ":memory:" → in-memory RB-tree indices @@ -95,7 +114,8 @@ '() (new-db-cache 10000) path - handles)]) + handles + (make-fulltext-index))]) conn))) ;; ---- close ---- @@ -127,6 +147,10 @@ (connection-tx-log-set! conn (cons report (connection-tx-log conn))) ;; Clear entity cache (conservative — could be smarter) (cache-clear! (connection-db-cache conn)) + ;; Update fulltext index with new datoms + (fulltext-index-datoms! (connection-fulltext-index conn) + (db-value-schema (tx-report-db-after report)) + (tx-report-tx-data report)) report)) ;; ---- Schema materialization ---- @@ -165,10 +189,13 @@ [no-hist? (get-val 'db/noHistory)] ;; Assign or lookup attribute ID [aid (schema-intern-attr! schema attr-ident)] + [tuple-attrs (get-val 'db/tupleAttrs)] + [ft? (get-val 'db/fulltext)] [db-attr (make-db-attribute attr-ident aid vtype card uniq (or idx? (and uniq #t)) - comp? doc no-hist?)]) + comp? doc no-hist? + tuple-attrs ft?)]) (schema-install-attribute! schema db-attr))) ident-datoms))) @@ -226,4 +253,21 @@ (define (schema-for conn) (schema-all-attributes (db-value-schema (db conn)))) + ;; ---- Fulltext search ---- + ;; Search for text in fulltext-indexed attributes on this connection. + + (define (fulltext-search conn attr-ident text) + (ft-search (connection-fulltext-index conn) + (db-value-schema (db conn)) + attr-ident + text)) + + ;; ---- Garbage collection ---- + + (define (gc-collect! conn . opts) + (apply gc-collect-db! (connection-current-db conn) opts)) + + (define (gc-stats conn . opts) + (apply gc-stats-db (connection-current-db conn) opts)) + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-db/fulltext.sls @@ -0,0 +1,170 @@ +#!chezscheme +;;; (jerboa-db fulltext) — In-memory fulltext search over string attributes +;;; +;;; Attributes marked with :db/fulltext true are indexed into an inverted word +;;; index. Supports word/substring search. + +(library (jerboa-db fulltext) + (export + make-fulltext-index fulltext-index? + fulltext-index-datoms! fulltext-remove-datoms! + ft-search fulltext-stats) + + (import (chezscheme) + (jerboa-db datom) + (jerboa-db schema)) + + ;; ---- Internal record ---- + ;; word-table: hashtable word -> list of (eid . attr-id) + ;; value-table: hashtable (eid . attr-id) -> value string + + (define-record-type ft-idx + (fields (mutable word-table) + (mutable value-table) + (mutable entry-count))) + + (define (make-fulltext-index) + (make-ft-idx (make-hashtable string-hash string=?) + (make-hashtable equal-hash equal?) + 0)) + + (define (fulltext-index? x) (ft-idx? x)) + + ;; ---- Tokenization ---- + + (define (tokenize str) + (let loop ([chars (string->list str)] [current '()] [result '()]) + (cond + [(null? chars) + (if (null? current) + result + (cons (list->string (reverse current)) result))] + [(or (char-alphabetic? (car chars)) (char-numeric? (car chars))) + (loop (cdr chars) + (cons (char-downcase (car chars)) current) + result)] + [else + (if (null? current) + (loop (cdr chars) '() result) + (loop (cdr chars) '() + (cons (list->string (reverse current)) result)))]))) + + ;; ---- Indexing ---- + + (define (fulltext-index-datoms! ft schema datoms) + (for-each + (lambda (d) + (let ([attr (schema-lookup-by-id schema (datom-a d))]) + (when (and attr (db-attribute-fulltext? attr) (string? (datom-v d))) + (if (datom-added? d) + (index-value! ft (datom-e d) (datom-a d) (datom-v d)) + (remove-value! ft (datom-e d) (datom-a d) (datom-v d)))))) + datoms)) + + (define (fulltext-remove-datoms! ft schema datoms) + (for-each + (lambda (d) + (let ([attr (schema-lookup-by-id schema (datom-a d))]) + (when (and attr (db-attribute-fulltext? attr) (string? (datom-v d))) + (remove-value! ft (datom-e d) (datom-a d) (datom-v d))))) + datoms)) + + (define (index-value! ft eid attr-id value) + (let ([key (cons eid attr-id)] + [wt (ft-idx-word-table ft)] + [vt (ft-idx-value-table ft)]) + ;; Remove any previous index for this key + (let ([old (hashtable-ref vt key #f)]) + (when old (remove-words! wt key (tokenize old)))) + ;; Store and index new value + (hashtable-set! vt key value) + (for-each + (lambda (word) + (let ([existing (hashtable-ref wt word '())]) + (unless (member key existing) + (hashtable-set! wt word (cons key existing))))) + (tokenize value)) + (ft-idx-entry-count-set! ft (+ (ft-idx-entry-count ft) 1)))) + + (define (remove-value! ft eid attr-id value) + (let ([key (cons eid attr-id)] + [wt (ft-idx-word-table ft)] + [vt (ft-idx-value-table ft)]) + (hashtable-delete! vt key) + (remove-words! wt key (tokenize value)) + (when (> (ft-idx-entry-count ft) 0) + (ft-idx-entry-count-set! ft (- (ft-idx-entry-count ft) 1))))) + + (define (remove-words! wt key words) + (for-each + (lambda (word) + (let ([existing (hashtable-ref wt word '())]) + (let ([updated (filter (lambda (k) (not (equal? k key))) existing)]) + (if (null? updated) + (hashtable-delete! wt word) + (hashtable-set! wt word updated))))) + words)) + + ;; ---- Search ---- + + ;; Returns list of (eid . value) pairs for entities whose attr value + ;; contains text as a substring (case-insensitive word-level match). + + (define (ft-search ft schema attr-ident text) + (let ([attr (schema-lookup-by-ident schema attr-ident)]) + (unless attr + (error 'ft-search "Unknown attribute" attr-ident)) + (let* ([attr-id (db-attribute-id attr)] + [wt (ft-idx-word-table ft)] + [vt (ft-idx-value-table ft)] + [needle (string-downcase* text)]) + ;; Walk word table, find words containing needle + (let ([matching-keys '()]) + (let-values ([(words key-lists) (hashtable-entries wt)]) + (vector-for-each + (lambda (word keys) + (when (string-contains? word needle) + (for-each + (lambda (key) + (when (and (= (cdr key) attr-id) + (not (member key matching-keys))) + (set! matching-keys (cons key matching-keys)))) + keys))) + words key-lists)) + ;; Build result + (filter-map + (lambda (key) + (let ([val (hashtable-ref vt key #f)]) + (and val (cons (car key) val)))) + matching-keys))))) + + ;; ---- Stats ---- + + (define (fulltext-stats ft) + (let-values ([(words _) (hashtable-entries (ft-idx-word-table ft))]) + (list (cons 'indexed-values (ft-idx-entry-count ft)) + (cons 'unique-words (vector-length words))))) + + ;; ---- Utilities ---- + + (define (string-downcase* s) + (list->string (map char-downcase (string->list s)))) + + (define (string-contains? haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (if (zero? nlen) + #t + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (loop (+ i 1))]))))) + + (define (filter-map f lst) + (let loop ([lst lst] [acc '()]) + (if (null? lst) (reverse acc) + (let ([r (f (car lst))]) + (loop (cdr lst) (if r (cons r acc) acc)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-db/gc.sls @@ -0,0 +1,115 @@ +#!chezscheme +;;; (jerboa-db gc) — Datom garbage collection +;;; +;;; Removes retracted datom pairs from indices to reclaim space. +;;; For attributes marked :db/noHistory, retracted datoms serve no purpose +;;; once retraction is confirmed. gc-collect-db! removes both the assertion +;;; and retraction datoms for such attribute/entity combos. +;;; +;;; The transaction log is NOT modified — GC only affects indices. +;;; +;;; Usage: call gc-collect-db! with a db-value. Wrap in core.sls: +;;; (define (gc-collect! conn . opts) (apply gc-collect-db! (db conn) opts)) + +(library (jerboa-db gc) + (export gc-collect-db! gc-stats-db) + + (import (chezscheme) + (jerboa-db datom) + (jerboa-db schema) + (jerboa-db index protocol) + (jerboa-db history)) + + ;; ---- gc-collect-db! ---- + ;; Takes a db-value. Scans EAVT, groups by (e,a,v). + ;; For each group where highest-tx is a retraction and attribute is noHistory + ;; (or collect-all? #t), removes all datoms in the group from all indices. + + (define (gc-collect-db! db-val . opts) + (let* ([collect-all? (and (pair? opts) (car opts))] + [schema (db-value-schema db-val)] + [indices (db-value-indices db-val)] + [eavt (index-set-eavt indices)] + [aevt (index-set-aevt indices)] + [avet (index-set-avet indices)] + [vaet (index-set-vaet indices)] + [examined 0] + [removed 0] + [t0 (time-second (current-time))]) + + ;; Group all EAVT datoms by (e, a, v) + (let ([groups (make-hashtable equal-hash equal?)]) + (for-each + (lambda (d) + (set! examined (+ examined 1)) + (let ([key (list (datom-e d) (datom-a d) (datom-v d))]) + (hashtable-set! groups key + (cons d (hashtable-ref groups key '()))))) + (dbi-datoms eavt)) + + ;; Process each group + (let-values ([(keys datom-lists) (hashtable-entries groups)]) + (vector-for-each + (lambda (key datoms) + (let* ([attr-id (cadr key)] + [attr (schema-lookup-by-id schema attr-id)] + [no-hist? (and attr (db-attribute-no-history? attr))] + [is-ref? (and attr (ref-type? attr))] + [is-idx? (and attr (indexed-attr? attr))]) + (when (or no-hist? collect-all?) + ;; Find highest-tx datom + (let* ([sorted (sort (lambda (a b) (> (datom-tx a) (datom-tx b))) datoms)] + [top (car sorted)]) + ;; GC only if the current state is retracted + (when (not (datom-added? top)) + (for-each + (lambda (d) + (set! removed (+ removed 1)) + (dbi-remove! eavt d) + (dbi-remove! aevt d) + (when is-idx? (dbi-remove! avet d)) + (when is-ref? (dbi-remove! vaet d))) + datoms)))))) + keys datom-lists))) + + (let ([t1 (time-second (current-time))]) + (list (cons 'examined examined) + (cons 'removed removed) + (cons 'duration-ms (* 1000 (- t1 t0))))))) + + ;; ---- gc-stats-db ---- + ;; Count reclaimable datoms without removing them. + + (define (gc-stats-db db-val . opts) + (let* ([collect-all? (and (pair? opts) (car opts))] + [schema (db-value-schema db-val)] + [indices (db-value-indices db-val)] + [eavt (index-set-eavt indices)] + [total 0] + [reclaimable 0]) + + (let ([groups (make-hashtable equal-hash equal?)]) + (for-each + (lambda (d) + (set! total (+ total 1)) + (let ([key (list (datom-e d) (datom-a d) (datom-v d))]) + (hashtable-set! groups key + (cons d (hashtable-ref groups key '()))))) + (dbi-datoms eavt)) + + (let-values ([(keys datom-lists) (hashtable-entries groups)]) + (vector-for-each + (lambda (key datoms) + (let* ([attr-id (cadr key)] + [attr (schema-lookup-by-id schema attr-id)] + [no-hist? (and attr (db-attribute-no-history? attr))] + [sorted (sort (lambda (a b) (> (datom-tx a) (datom-tx b))) datoms)] + [top (car sorted)]) + (when (and (not (datom-added? top)) (or no-hist? collect-all?)) + (set! reclaimable (+ reclaimable (length datoms)))))) + keys datom-lists))) + + (list (cons 'total-datoms total) + (cons 'reclaimable reclaimable)))) + +) ;; end library --- a/lib/jerboa-db/peer.sls +++ b/lib/jerboa-db/peer.sls @@ -3,10 +3,14 @@ ;;; ;;; Connects to a Jerboa-DB server over HTTP/WebSocket. ;;; Same API as embedded mode (connect, db, transact!, q, pull). +;;; +;;; Automatic failover: connect-remote* accepts a list of URLs. If a request +;;; to the primary URL fails, the client retries the next URL with exponential +;;; backoff. Useful for Raft-based HA deployments where leadership can change. (library (jerboa-db peer) (export - connect-remote remote-connection? + connect-remote connect-remote* remote-connection? remote-db remote-transact! remote-q remote-pull remote-tx-stream) @@ -21,13 +25,29 @@ ;; ---- Remote connection ---- (define-record-type remote-connection - (fields url ;; base URL: "http://localhost:8484" - (mutable last-tx))) ;; last known transaction ID + (fields (mutable urls) ;; list of URLs, first is current primary + (mutable last-tx) ;; last known transaction ID + (mutable retry-count))) ;; consecutive failures on current primary + + (define (make-single-remote-connection url) + (make-remote-connection (list url) 0 0)) + + ;; ---- URL management ---- - ;; ---- Helpers ---- + (define (current-url conn) + (car (remote-connection-urls conn))) (define (build-url conn path) - (string-append (remote-connection-url conn) path)) + (string-append (current-url conn) path)) + + ;; Rotate: move failed primary to end, try next URL + (define (failover! conn) + (let ([urls (remote-connection-urls conn)]) + (when (> (length urls) 1) + (remote-connection-urls-set! conn (append (cdr urls) (list (car urls)))) + (remote-connection-retry-count-set! conn 0)))) + + ;; ---- HTTP helpers ---- (define (check-response! who resp url) (let ([status (request-status resp)]) @@ -36,84 +56,120 @@ (string-append "HTTP error " (number->string status) " from " url) (request-text resp))))) + ;; Execute a thunk with retry+failover on transient errors. + ;; Retries up to max-retries times with exponential backoff (100ms, 200ms, 400ms). + + (define (with-retry conn thunk max-retries) + (let loop ([attempt 0]) + (guard (exn + [#t + (remote-connection-retry-count-set! conn + (+ (remote-connection-retry-count conn) 1)) + (if (< attempt max-retries) + (begin + (failover! conn) + ;; Exponential backoff: sleep 100ms * 2^attempt + (let ([delay-s (/ (* 100 (expt 2 attempt)) 1000)]) + (sleep (make-time 'time-duration + (inexact->exact (floor (* delay-s 1000000000))) + 0))) + (loop (+ attempt 1))) + (raise exn))]) + (thunk)))) + ;; POST with EDN body; returns parsed EDN from response body. (define (post-edn conn path body-obj) - (let* ([url (build-url conn path)] - [body (edn->string body-obj)] - [resp (http-post url - '(("Content-Type" . "application/edn") - ("Accept" . "application/edn")) - body)]) - (check-response! 'post-edn resp url) - (string->edn (request-text resp)))) + (with-retry conn + (lambda () + (let* ([url (build-url conn path)] + [body (edn->string body-obj)] + [resp (http-post url + '(("Content-Type" . "application/edn") + ("Accept" . "application/edn")) + body)]) + (check-response! 'post-edn resp url) + (string->edn (request-text resp)))) + 3)) ;; GET; returns parsed EDN from response body. (define (get-edn conn path) - (let* ([url (build-url conn path)] - [resp (http-get url - '(("Accept" . "application/edn")))]) - (check-response! 'get-edn resp url) - (string->edn (request-text resp)))) + (with-retry conn + (lambda () + (let* ([url (build-url conn path)] + [resp (http-get url '(("Accept" . "application/edn")))]) + (check-response! 'get-edn resp url) + (string->edn (request-text resp)))) + 3)) ;; ---- connect-remote ---- - ;; Verifies connectivity via GET /health and returns a connection record. + ;; Single URL. Verifies connectivity via GET /health. (define (connect-remote url) - (let* ([health-url (string-append url "/health")] + (let ([conn (make-single-remote-connection url)]) + (verify-connectivity! conn) + conn)) + + ;; ---- connect-remote* ---- + ;; Multiple URLs for automatic failover. + + (define (connect-remote* urls) + (unless (pair? urls) + (error 'connect-remote* "At least one URL required")) + (let ([conn (make-remote-connection urls 0 0)]) + ;; Try to connect to any available URL + (let loop ([remaining urls]) + (if (null? remaining) + (error 'connect-remote* "Could not reach any server" urls) + (guard (exn [#t (loop (cdr remaining))]) + (remote-connection-urls-set! conn + (append (list (car remaining)) + (filter (lambda (u) (not (string=? u (car remaining)))) urls))) + (verify-connectivity! conn)))) + conn)) + + (define (verify-connectivity! conn) + (let* ([health-url (string-append (current-url conn) "/health")] [resp (guard (exn [#t #f]) (http-get health-url))]) (unless resp - (error 'connect-remote "Cannot reach server" url)) - (let ([status (request-status resp)] - [body (request-text resp)]) - (unless (and (= status 200) (string? body) (string=? body "ok")) - (error 'connect-remote "Server health check failed" url status))) - (make-remote-connection url 0))) + (error 'connect-remote "Cannot reach server" (current-url conn))) + (let ([status (request-status resp)]) + (unless (= status 200) + (error 'connect-remote "Server health check failed" + (current-url conn) status))))) ;; ---- remote-db ---- - ;; Fetches current db stats; updates cached last-tx. (define (remote-db conn) (let ([stats (get-edn conn "/api/db/stats")]) (when (pair? stats) - (let ([basis-tx-entry (assq 'basis-tx stats)]) - (when basis-tx-entry - (remote-connection-last-tx-set! conn (cdr basis-tx-entry))))) + (let ([e (assq 'basis-tx stats)]) + (when e (remote-connection-last-tx-set! conn (cdr e))))) stats)) ;; ---- remote-transact! ---- - ;; POST /api/transact with EDN tx-ops, returns the tx report alist. (define (remote-transact! conn tx-ops) (let ([result (post-edn conn "/api/transact" tx-ops)]) (when (pair? result) - (let ([tx-id-entry (assq 'tx-id result)]) - (when tx-id-entry - (remote-connection-last-tx-set! conn (cdr tx-id-entry))))) + (let ([e (assq 'tx-id result)]) + (when e (remote-connection-last-tx-set! conn (cdr e))))) result)) ;; ---- remote-q ---- - ;; POST /api/query with EDN query form, returns list of result tuples. (define (remote-q conn query-form) (post-edn conn "/api/query" query-form)) ;; ---- remote-pull ---- - ;; POST /api/pull with EDN [pattern eid], returns entity map. (define (remote-pull conn pattern eid) (post-edn conn "/api/pull" (list pattern eid))) ;; ---- remote-tx-stream ---- - ;; Connects to /api/tx-stream via WebSocket, calls handler with each - ;; transaction report (as a parsed EDN alist) until the stream ends. - ;; handler: (lambda (tx-data) ...) where tx-data is a parsed EDN value. - ;; - ;; Note: This is a synchronous loop; run in a separate thread to avoid - ;; blocking the caller. (define (remote-tx-stream conn handler) (error 'remote-tx-stream - "WebSocket tx-stream requires fiber context; use (std fiber) to spawn a fiber and call remote-tx-stream/fiber instead")) + "WebSocket tx-stream requires fiber context; use (std fiber) to spawn")) ) ;; end library --- a/lib/jerboa-db/schema.sls +++ b/lib/jerboa-db/schema.sls @@ -12,6 +12,7 @@ db-attribute-ident db-attribute-id db-attribute-value-type db-attribute-cardinality db-attribute-unique db-attribute-index? db-attribute-is-component? db-attribute-doc db-attribute-no-history? + db-attribute-tuple-attrs db-attribute-fulltext? ;; Schema registry new-schema-registry schema-registry? @@ -23,6 +24,8 @@ +db/ident+ +db/valueType+ +db/cardinality+ +db/unique+ +db/index+ +db/doc+ +db/isComponent+ +db/noHistory+ +db/txInstant+ +db/id+ + +db/tupleAttrs+ +db/ensure+ +db/fulltext+ + +spec/ident+ +spec/attrs+ +first-user-attr-id+ ;; Value type predicates @@ -45,7 +48,9 @@ index? ;; boolean — populate AVET? is-component? ;; boolean — cascade retractions? doc ;; string or #f - no-history?)) ;; boolean — skip history? + no-history? ;; boolean — skip history? + tuple-attrs ;; list of component attr ident symbols for composite, or #f + fulltext?)) ;; boolean — enable fulltext indexing ;; ---- Schema registry ---- ;; Maps ident (symbol) <-> id (integer), and id -> db-attribute. @@ -109,6 +114,11 @@ (define +db/noHistory+ 'db/noHistory) (define +db/txInstant+ 'db/txInstant) (define +db/id+ 'db/id) + (define +db/tupleAttrs+ 'db/tupleAttrs) + (define +db/ensure+ 'db/ensure) + (define +db/fulltext+ 'db/fulltext) + (define +spec/ident+ 'spec/ident) + (define +spec/attrs+ 'spec/attrs) (define +first-user-attr-id+ 20) @@ -116,7 +126,7 @@ (define (bootstrap-schema! reg) (define (install! id ident vtype card) - (let ([attr (make-db-attribute ident id vtype card #f #t #f #f #f)]) + (let ([attr (make-db-attribute ident id vtype card #f #t #f #f #f #f #f)]) (schema-install-attribute! reg attr))) ;; Reserve IDs 0-19 for system attributes (install! 0 +db/ident+ 'db.type/keyword 'db.cardinality/one) @@ -128,6 +138,11 @@ (install! 6 +db/isComponent+ 'db.type/boolean 'db.cardinality/one) (install! 7 +db/noHistory+ 'db.type/boolean 'db.cardinality/one) (install! 8 +db/txInstant+ 'db.type/instant 'db.cardinality/one) + (install! 9 +db/tupleAttrs+ 'db.type/any 'db.cardinality/one) + (install! 10 +db/ensure+ 'db.type/keyword 'db.cardinality/one) + (install! 11 +db/fulltext+ 'db.type/boolean 'db.cardinality/one) + (install! 12 +spec/ident+ 'db.type/keyword 'db.cardinality/one) + (install! 13 +spec/attrs+ 'db.type/any 'db.cardinality/one) (schema-registry-next-id-set! reg +first-user-attr-id+)) ;; ---- Value type validation ---- @@ -136,7 +151,7 @@ (memq vtype '(db.type/string db.type/long db.type/double db.type/boolean db.type/instant db.type/uuid db.type/ref db.type/keyword db.type/bytes - db.type/symbol))) + db.type/symbol db.type/tuple db.type/any))) (define (value-matches-type? vtype value) (case vtype @@ -150,6 +165,8 @@ [(db.type/keyword) (symbol? value)] [(db.type/bytes) (bytevector? value)] [(db.type/symbol) (symbol? value)] + [(db.type/tuple) (list? value)] + [(db.type/any) #t] [else #f])) (define (coerce-value vtype raw) new file mode 100644 --- /dev/null +++ b/lib/jerboa-db/spec.sls @@ -0,0 +1,148 @@ +#!chezscheme +;;; (jerboa-db spec) — Entity specs and attribute predicate validation +;;; +;;; A spec defines required attributes for an entity type. +;;; Define a spec by transacting: +;;; ((spec/ident . person-spec) (spec/attrs . (person/name person/email))) +;;; +;;; Then validate: +;;; (validate-entity db eid 'person-spec) → #t or raises error +;;; (check-entity-spec db eid 'person-spec) → (ok . eid) or (err . missing-list) + +(library (jerboa-db spec) + (export define-spec validate-entity check-entity-spec) + + (import (chezscheme) + (jerboa-db datom) + (jerboa-db schema) + (jerboa-db index protocol) + (jerboa-db history)) + + ;; ---- define-spec ---- + ;; Convenience: transact a spec entity using the connection. + ;; Returns a tx-op list suitable for passing to transact! + + (define (define-spec spec-ident required-attrs) + ;; Returns a tx-op (entity map alist) ready for transact! + (list (cons 'spec/ident spec-ident) + (cons 'spec/attrs required-attrs))) + + ;; ---- Spec lookup ---- + ;; Find the spec entity with spec/ident = spec-ident. + ;; Returns a list of required attribute ident symbols, or #f if not found. + + (define (find-spec-attrs db-val spec-ident) + (let* ([schema (db-value-schema db-val)] + [indices (db-value-indices db-val)] + [avet (index-set-avet indices)] + [spec-attr (schema-lookup-by-ident schema 'spec/ident)] + [attrs-attr (schema-lookup-by-ident schema 'spec/attrs)]) + (unless spec-attr (error 'find-spec-attrs "spec/ident not in schema")) + (unless attrs-attr (error 'find-spec-attrs "spec/attrs not in schema")) + (let* ([spec-aid (db-attribute-id spec-attr)] + [lo (make-datom 0 spec-aid spec-ident 0 #t)] + [hi (make-datom (greatest-fixnum) spec-aid spec-ident (greatest-fixnum) #t)] + [datoms (filter (lambda (d) (db-filter-datom? db-val d)) + (dbi-range avet lo hi))] + [spec-entities (resolve-current-eids datoms)]) + (if (null? spec-entities) + #f + ;; Use the first matching spec entity + (let* ([spec-eid (car spec-entities)] + [attrs-aid (db-attribute-id attrs-attr)] + [eavt (index-set-eavt indices)] + [lo2 (make-datom spec-eid attrs-aid +min-val+ 0 #t)] + [hi2 (make-datom spec-eid attrs-aid +max-val+ (greatest-fixnum) #t)] + + [attr-datoms (filter (lambda (d) (db-filter-datom? db-val d)) + (dbi-range eavt lo2 hi2))] + [current-attr-datoms (resolve-current-datoms attr-datoms)]) + (if (null? current-attr-datoms) + '() + (datom-v (car current-attr-datoms)))))))) + + ;; ---- Entity value check ---- + ;; Check if entity eid has a current value for attr-ident. + + (define (entity-has-attr? db-val eid attr-ident) + (let* ([schema (db-value-schema db-val)] + [indices (db-value-indices db-val)] + [attr (schema-lookup-by-ident schema attr-ident)]) + (and attr + (let* ([aid (db-attribute-id attr)] + [eavt (index-set-eavt indices)] + [lo (make-datom eid aid +min-val+ 0 #t)] + [hi (make-datom eid aid +max-val+ (greatest-fixnum) #t)] + [datoms (filter (lambda (d) (db-filter-datom? db-val d)) + (dbi-range eavt lo hi))] + [current (resolve-current-datoms datoms)]) + (not (null? current)))))) + + ;; ---- validate-entity ---- + ;; Checks that eid has all required attributes from spec. + ;; Returns #t on success, raises error on failure. + + (define (validate-entity db-val eid spec-ident) + (let ([required (find-spec-attrs db-val spec-ident)]) + (unless required + (error 'validate-entity "Spec not found" spec-ident)) + (let ([missing (filter (lambda (attr-ident) + (not (entity-has-attr? db-val eid attr-ident))) + required)]) + (if (null? missing) + #t + (error 'validate-entity + (format #f "Entity ~a missing required attributes for spec ~a: ~a" + eid spec-ident missing)))))) + + ;; ---- check-entity-spec ---- + ;; Returns (ok . eid) on success or (err . missing-attr-list) on failure.