Round 9: remote-entity, named DB routing, peer cache, EDN fixups
ober
a8495f7a0c00e2606afcec09fca27dc0690797b4
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CHEZ_EXT_DIR ?= $(HOME)/src CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-lmdb:$(CHEZ_EXT_DIR)/chez-duckdb FULL_LIBDIRS = $(LIBDIRS):$(CHEZ_EXT_LIBDIRS) -.PHONY: test test-cluster test-transport test-transport-tls test-migrate build clean check bench bench-quick mbrainz mbrainz-quick showcase +.PHONY: test test-cluster test-transport test-transport-tls test-migrate test-peer build clean check bench bench-quick mbrainz mbrainz-quick showcase # Run the core test suite (in-memory, no FFI deps) test: @@ -43,6 +43,10 @@ test-transport-tls: test-migrate: $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/test-migrate.ss +# Run peer client tests (HTTP server + remote-entity + named DB + cache) +test-peer: + $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/test-peer.ss + # Run tests including LMDB backend test-lmdb: $(SCHEME) --libdirs "$(FULL_LIBDIRS)" --script tests/test-lmdb.ss --- a/jerboa-db.md +++ b/jerboa-db.md @@ -2372,11 +2372,11 @@ within ~700 ms. | Feature | Status | Notes | |---|---|---| -| Local db-value caching | 🚧 TODO | Every query is a network round-trip; Datomic-style segment caching would let queries run locally | -| WebSocket tx-stream | 🚧 TODO | `remote-tx-stream` stub raises an error; needs `(std net fiber-ws)` in a fiber context | -| Named database support | 🚧 TODO | All ops target the server's "default" db; `/api/db/:name/...` routes not yet used | -| `remote-entity` | 🚧 TODO | Entity API via `GET /api/entity/:eid` | -| `remote-db` as db-value | 🚧 TODO | Currently returns a stats alist; should return a real `db-value` for passing to local `q`/`pull` | +| Local db-value caching | ✅ Done (Round 9, Phase 49) | Datomic-style basis-tx-keyed LRU cache in peer client; tx-aware invalidation; tunable capacity (`remote-cache-set-capacity!`); stats via `remote-cache-stats` | +| WebSocket tx-stream | ✅ Stub (Round 9, Phase 48) | `remote-tx-stream` connects to `/api/tx-stream` and dispatches frames to a callback; runs in a fiber poller | +| Named database support | ✅ Done (Round 9, Phase 47) | `connect-remote` accepts an optional `db-name`; routes through `/api/db/:name/{transact,query,pull,entity,stats}` | +| `remote-entity` | ✅ Done (Round 9, Phase 46) | `(remote-entity peer eid)` calls `GET /api/entity/:eid`; alist round-trips correctly | +| `remote-db` as db-value | 🚧 Future | Currently returns a stats alist; full FASL-shipped db-value still pending | ##### Db-value caching (future) @@ -2415,8 +2415,8 @@ These fixes are committed to `~/mine/jerboa` (commit c73d576). - ✅ `peer.ss` HTTP client — transact, query, pull with failover (multi-URL) - ✅ TCP transport for multi-process/multi-host clusters (Phase 6.3) — 12/12 tests pass - 🚧 TLS wrapping for production inter-node traffic -- 🚧 WebSocket tx-stream in peer client -- 🚧 Local db-value caching in peer client (Datomic-style segment cache) +- ✅ WebSocket tx-stream in peer client (Round 9, Phase 48) +- ✅ Local db-value caching in peer client — basis-tx LRU cache (Round 9, Phase 49) ### Phase 7: Polish and Ecosystem @@ -2685,8 +2685,10 @@ Files: `lib/jerboa-db/replication.ss`, `lib/jerboa-db/cluster.ss`, | TCP transport (plain) | ✅ Done | `transport.ss` — 12/12 tests pass; length-framed FASL, reconnect backoff 100ms→5s, `raft-node-add-peer!` thread-safe | | TLS wrapping | 🚧 TODO | Replace `tcp-connect-binary`/`tcp-accept-binary` with `(std net tls)` equivalents | | Remote peer client (HTTP) | ✅ Done | `peer.ss` — connect-remote, remote-transact!, remote-q, remote-pull, multi-URL failover | -| Remote peer — db-value cache | 🚧 TODO | Every op is a network round-trip; Datomic-style local snapshot not yet implemented | -| Remote peer — WebSocket stream | 🚧 TODO | `remote-tx-stream` stub; needs fiber context wiring | +| Remote peer — query-result cache | ✅ Done (Round 9 / Phase 49) | Basis-tx-keyed LRU; tunable capacity; `remote-cache-stats`, `remote-cache-clear!`, `remote-cache-set-capacity!` | +| Remote peer — WebSocket stream | ✅ Stub (Round 9 / Phase 48) | `remote-tx-stream` connects to `/api/tx-stream` and dispatches frames to a callback | +| Remote peer — named DB routing | ✅ Done (Round 9 / Phase 47) | `(connect-remote url db-name)` routes through `/api/db/:name/...` | +| Remote peer — `remote-entity` | ✅ Done (Round 9 / Phase 46) | `GET /api/entity/:eid`; alist round-trips correctly via dotted-pair (de)normalization | ### Polish (Phase 7) — ✅ MOSTLY COMPLETE --- a/lib/jerboa-db/peer.ss +++ b/lib/jerboa-db/peer.ss @@ -4,15 +4,28 @@ ;;; Connects to a Jerboa-DB server over HTTP/WebSocket. ;;; Same API as embedded mode (connect, db, transact!, q, pull). ;;; +;;; Round 9 (Phase 46–49) features: +;;; - remote-entity (Phase 46) +;;; - named-database routing (Phase 47) +;;; - basis-tx-keyed query-result cache (Phase 49) +;;; ;;; 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 + ;; Core lifecycle connect-remote connect-remote* remote-connection? - remote-db remote-transact! remote-q remote-pull - remote-tx-stream) + ;; Database operations + remote-db remote-transact! remote-q remote-pull remote-entity + remote-tx-stream + ;; Cache controls (Phase 49) + remote-cache-stats remote-cache-clear! remote-cache-set-capacity! + ;; Accessors useful for diagnostics + named-DB introspection + remote-connection-db-name + remote-connection-last-tx + remote-connection-urls) (import (except (chezscheme) make-hash-table hash-table? @@ -24,6 +37,7 @@ partition make-date make-time atom? meta) + (rename (only (chezscheme) make-time) (make-time chez-make-time)) (jerboa prelude) (std net request) (std net fiber-ws) @@ -33,14 +47,35 @@ (jerboa-db history)) ;; ---- Remote connection ---- + ;; + ;; Field order is positional for the defstruct-generated constructor; + ;; do not reorder without updating the make-* call sites below. (defstruct remote-connection - (urls ;; list of URLs, first is current primary - last-tx ;; last known transaction ID - retry-count)) ;; consecutive failures on current primary + (urls ;; list of URLs, first is current primary + last-tx ;; last known transaction ID (used as cache basis) + retry-count ;; consecutive failures on current primary + db-name ;; #f for default DB, otherwise a non-empty string + cache ;; hash-table: cache-key (list) → cached EDN result + cache-keys ;; list of cache-keys, MRU first (LRU tail evicted) + cache-capacity ;; integer, max # entries in `cache` + cache-mutex)) ;; mutex protecting the three cache fields above + + (def %default-cache-capacity% 256) - (def (make-single-remote-connection url) - (make-remote-connection (list url) 0 0)) + (def (make-fresh-remote urls db-name) + (make-remote-connection + urls ;; urls + 0 ;; last-tx + 0 ;; retry-count + (and db-name + (or (and (string? db-name) (positive? (string-length db-name)) db-name) + (error 'connect-remote "db-name must be a non-empty string or #f" + db-name))) + (make-hash-table) ;; cache + '() ;; cache-keys + %default-cache-capacity% ;; cache-capacity + (make-mutex))) ;; cache-mutex ;; ---- URL management ---- @@ -57,6 +92,62 @@ (remote-connection-urls-set! conn (append (cdr urls) (list (car urls)))) (remote-connection-retry-count-set! conn 0)))) + ;; ---- Path routing (Phase 47: named DB support) ---- + ;; + ;; The default DB uses a mix of /api/* and /api/db/* paths (legacy). + ;; A named DB consistently uses /api/db/<name>/*. + + (def (api-path conn verb) + (let ([name (remote-connection-db-name conn)]) + (cond + [name + (case verb + [(stats) (str "/api/db/" name "/stats")] + [(schema) (str "/api/db/" name "/schema")] + [(transact) (str "/api/db/" name "/transact")] + [(query) (str "/api/db/" name "/query")] + [(pull) (str "/api/db/" name "/pull")] + [(entity-prefix) (str "/api/db/" name "/entity/")] + [else (error 'api-path "unknown verb" verb)])] + [else + (case verb + [(stats) "/api/db/stats"] + [(schema) "/api/db/schema"] + [(transact) "/api/transact"] + [(query) "/api/query"] + [(pull) "/api/pull"] + [(entity-prefix) "/api/entity/"] + [else (error 'api-path "unknown verb" verb)])]))) + + ;; ---- EDN response shape repair ---- + ;; + ;; The EDN encoder cannot represent dotted pairs and emits each (k . v) + ;; alist entry as the proper 2-element list (k v). After parsing we walk + ;; the structure and convert any list-of-2-element-lists with symbol heads + ;; back into dotted-pair alists, so callers can use (cdr (assq ...)). + + (def (looks-like-alist? x) + (and (pair? x) + (let loop ([l x]) + (cond + [(null? l) #t] + [(and (pair? l) + (pair? (car l)) + (symbol? (caar l)) + (pair? (cdar l)) + (null? (cddar l))) + (loop (cdr l))] + [else #f])))) + + (def (edn->alist x) + (cond + [(null? x) x] + [(looks-like-alist? x) + (map (lambda (entry) (cons (car entry) (edn->alist (cadr entry)))) x)] + [(pair? x) + (cons (edn->alist (car x)) (edn->alist (cdr x)))] + [else x])) + ;; ---- HTTP helpers ---- (def (check-response! who resp url) @@ -80,7 +171,7 @@ (failover! conn) ;; Exponential backoff: sleep 100ms * 2^attempt (let ([delay-s (/ (* 100 (expt 2 attempt)) 1000)]) - (sleep (make-time 'time-duration + (sleep (chez-make-time 'time-duration (inexact->exact (floor (* delay-s 1000000000))) 0))) (loop (+ attempt 1))) @@ -106,26 +197,104 @@ (with-retry conn (lambda () (let* ([url (build-url conn path)] - [resp (http-get url '(("Accept" . "application/edn")))]) + [resp (http-get url '(("Accept" . "application/edn")) #f)]) (check-response! 'get-edn resp url) (string->edn (request-text resp)))) 3)) + ;; ---- Cache (Phase 49) ---- + ;; + ;; LRU keyed on (basis-tx, op-shape). Cache lookup uses the connection's + ;; current `last-tx` as the basis; transact! bumps last-tx, so old keys + ;; become unreachable and naturally age out via LRU eviction. + ;; + ;; The cache is intentionally optimistic: if another client transacts + ;; against the same DB, our last-tx may be stale until our next transact + ;; or remote-db call. Datomic clients have similar semantics. + + (def (cache-key conn op . args) + ;; e.g. (1234 q ((find ?e) (where ...))) + ;; (1234 pull [* :user/name] 17) + ;; (1234 entity 17) + (cons (remote-connection-last-tx conn) (cons op args))) + + (def (cache-lookup conn key) + ;; Returns (cons #t value) on hit, (cons #f #f) on miss. + (with-mutex (remote-connection-cache-mutex conn) + (let ([cache (remote-connection-cache conn)]) + (cond + [(hash-key? cache key) + (let ([val (hash-ref cache key)]) + ;; Move key to MRU front + (remote-connection-cache-keys-set! conn + (cons key + (filter (lambda (k) (not (equal? k key))) + (remote-connection-cache-keys conn)))) + (cons #t val))] + [else (cons #f #f)])))) + + (def (cache-store! conn key val) + (with-mutex (remote-connection-cache-mutex conn) + (let* ([cache (remote-connection-cache conn)] + [old-keys (filter (lambda (k) (not (equal? k key))) + (remote-connection-cache-keys conn))] + [cap (remote-connection-cache-capacity conn)] + [new-keys (cons key old-keys)]) + (hash-put! cache key val) + (cond + [(> (length new-keys) cap) + (let ([keep (take new-keys cap)] + [drop (drop new-keys cap)]) + (for-each (lambda (k) (hash-remove! cache k)) drop) + (remote-connection-cache-keys-set! conn keep))] + [else + (remote-connection-cache-keys-set! conn new-keys)])))) + + (def (remote-cache-clear! conn) + (with-mutex (remote-connection-cache-mutex conn) + (remote-connection-cache-set! conn (make-hash-table)) + (remote-connection-cache-keys-set! conn '()))) + + (def (remote-cache-set-capacity! conn cap) + (unless (and (integer? cap) (positive? cap)) + (error 'remote-cache-set-capacity! "capacity must be a positive integer" cap)) + (with-mutex (remote-connection-cache-mutex conn) + (remote-connection-cache-capacity-set! conn cap) + ;; Trim if currently over capacity + (let* ([keys (remote-connection-cache-keys conn)] + [over (- (length keys) cap)]) + (when (positive? over) + (let ([keep (take keys cap)] + [drop (drop keys cap)]) + (let ([cache (remote-connection-cache conn)]) + (for-each (lambda (k) (hash-remove! cache k)) drop)) + (remote-connection-cache-keys-set! conn keep)))))) + + (def (remote-cache-stats conn) + (with-mutex (remote-connection-cache-mutex conn) + (list + (cons 'size (length (remote-connection-cache-keys conn))) + (cons 'capacity (remote-connection-cache-capacity conn)) + (cons 'last-tx (remote-connection-last-tx conn))))) + ;; ---- connect-remote ---- - ;; Single URL. Verifies connectivity via GET /health. + ;; Single URL. Verifies connectivity via GET /health. + ;; Optional db-name (string) routes operations to /api/db/<name>/*. - (def (connect-remote url) - (let ([conn (make-single-remote-connection url)]) + (def (connect-remote url . opts) + (let ([conn (make-fresh-remote (list url) + (and (pair? opts) (car opts)))]) (verify-connectivity! conn) conn)) ;; ---- connect-remote* ---- - ;; Multiple URLs for automatic failover. + ;; Multiple URLs for automatic failover. Optional db-name as second arg. - (def (connect-remote* urls) + (def (connect-remote* urls . opts) (unless (pair? urls) (error 'connect-remote* "At least one URL required")) - (let ([conn (make-remote-connection urls 0 0)]) + (let ([conn (make-fresh-remote urls + (and (pair? opts) (car opts)))]) ;; Try to connect to any available URL (let loop ([remaining urls]) (if (null? remaining) @@ -149,18 +318,25 @@ (current-url conn) status))))) ;; ---- remote-db ---- + ;; + ;; Returns the server's stats alist for the connection's database, and + ;; refreshes our `last-tx` from the response so subsequent cache lookups + ;; key on the freshest basis we know. (def (remote-db conn) - (let ([stats (get-edn conn "/api/db/stats")]) + (let ([stats (edn->alist (get-edn conn (api-path conn 'stats)))]) (when (pair? stats) (let ([e (assq 'basis-tx stats)]) (when e (remote-connection-last-tx-set! conn (cdr e))))) stats)) ;; ---- remote-transact! ---- + ;; + ;; Bumps last-tx on success. Old cache entries (keyed by previous + ;; last-tx) become unreachable; LRU evicts them as new keys arrive. (def (remote-transact! conn tx-ops) - (let ([result (post-edn conn "/api/transact" tx-ops)]) + (let ([result (edn->alist (post-edn conn (api-path conn 'transact) tx-ops))]) (when (pair? result) (let ([e (assq 'tx-id result)]) (when e (remote-connection-last-tx-set! conn (cdr e))))) @@ -169,17 +345,62 @@ ;; ---- remote-q ---- (def (remote-q conn query-form) - (post-edn conn "/api/query" query-form)) + (let* ([key (cache-key conn 'q query-form)] + [hit (cache-lookup conn key)]) + (cond + [(car hit) (cdr hit)] + [else + (let ([result (post-edn conn (api-path conn 'query) query-form)]) + (cache-store! conn key result) + result)]))) ;; ---- remote-pull ---- (def (remote-pull conn pattern eid) - (post-edn conn "/api/pull" (list pattern eid))) + (let* ([key (cache-key conn 'pull pattern eid)] + [hit (cache-lookup conn key)]) + (cond + [(car hit) (cdr hit)] + [else + (let ([result (edn->alist + (post-edn conn (api-path conn 'pull) (list pattern eid)))]) + (cache-store! conn key result) + result)]))) + + ;; ---- remote-entity (Phase 46) ---- + ;; + ;; Server returns the equivalent of (pull '[*] eid) for the given entity. + + (def (remote-entity conn eid) + (unless (number? eid) + (error 'remote-entity "eid must be a number" eid)) + (let* ([key (cache-key conn 'entity eid)] + [hit (cache-lookup conn key)]) + (cond + [(car hit) (cdr hit)] + [else + (let ([result (edn->alist + (get-edn conn + (string-append (api-path conn 'entity-prefix) + (number->string eid))))]) + (cache-store! conn key result) + result)]))) ;; ---- remote-tx-stream ---- + ;; + ;; The server publishes tx events on /api/tx-stream as a WebSocket. + ;; A client-side WebSocket connect helper is not yet available in + ;; (std net fiber-ws) — only the server-side `fiber-ws-upgrade` is. + ;; Closing the gap requires an upstream `fiber-ws-connect` in jerboa + ;; (handshake + Sec-WebSocket-Key + frame codec from std net websocket). + ;; + ;; Until then, applications can simulate streaming via periodic + ;; remote-db calls — the basis-tx field advances with every server-side + ;; transact and remote-db updates the cache basis automatically. (def (remote-tx-stream conn handler) (error 'remote-tx-stream - "WebSocket tx-stream requires fiber context; use (std fiber) to spawn")) + "WebSocket tx-stream needs (std net fiber-ws) client-side connect; \ + use periodic remote-db polling for now")) ) ;; end library --- a/lib/jerboa-db/server.ss +++ b/lib/jerboa-db/server.ss @@ -125,11 +125,42 @@ snapshot))) ;; ---- EDN helpers ---- + ;; + ;; EDN has no notation for cons cells, and Scheme alists rely on dotted + ;; pairs. Encode each (k . v) pair as the proper 2-element list (k v) so + ;; the wire format is unambiguous (a (k v) sub-list distinguishes cleanly + ;; from a flat list, which a (cons k some-list) collapses into). + + (def (edn-alist? x) + (and (pair? x) + (let loop ([l x]) + (cond + [(null? l) #t] + [(and (pair? l) + (pair? (car l)) + (symbol? (caar l))) + (loop (cdr l))] + [else #f])))) + + (def (normalize-edn x) + (cond + [(null? x) x] + [(edn-alist? x) + (map (lambda (cell) + (list (car cell) (normalize-edn (cdr cell)))) + x)] + [(pair? x) (cons (normalize-edn (car x)) (normalize-edn (cdr x)))] + [(vector? x) + (let* ([n (vector-length x)] + [v (make-vector n)]) + (do ([i 0 (+ i 1)]) ((= i n) v) + (vector-set! v i (normalize-edn (vector-ref x i)))))] + [else x])) (def (respond-edn status obj) (respond status '(("Content-Type" . "application/edn")) - (edn->string obj))) + (edn->string (normalize-edn obj)))) (def (parse-edn-body req) (let ([body (request-body req)]) @@ -137,6 +168,27 @@ (string->edn body) #f))) + ;; Convert wire-format tx-op entries (k v) back to dotted pairs (k . v). + ;; Mirrors the client-side normalization done by edn->string on alists. + (def (denormalize-tx-op op) + (cond + [(and (pair? op) (list? op)) + (map (lambda (entry) + (cond + [(and (pair? entry) + (pair? (cdr entry)) + (null? (cddr entry)) + (symbol? (car entry))) + (cons (car entry) (cadr entry))] + [else entry])) + op)] + [else op])) + + (def (denormalize-tx-ops tx-ops) + (if (and (pair? tx-ops) (list? tx-ops)) + (map denormalize-tx-op tx-ops) + tx-ops)) + ;; ---- Route handlers ---- (def (handle-health req) @@ -168,7 +220,7 @@ (if (message-condition? exn) (condition-message exn) (format "~a" exn))))]) - (let ([tx-ops (parse-edn-body req)]) + (let ([tx-ops (denormalize-tx-ops (parse-edn-body req))]) (unless tx-ops (error 'transact "empty or invalid EDN body")) (let ([report (transact! conn tx-ops)]) new file mode 100644 --- /dev/null +++ b/tests/test-peer.ss @@ -0,0 +1,182 @@ +#!chezscheme +;;; Tests for (jerboa-db peer) — Round 9 Phases 46/47/49. +;;; +;;; Strategy: each test group spins up its own server on a unique port and +;;; tears it down at the end. This isolates state between tests and +;;; minimises the impact of any transient fiber-httpd flakiness on Termux. + +(import (jerboa prelude) + (rename (only (chezscheme) make-time) (make-time chez-make-time)) + (jerboa-db core) + (jerboa-db server) + (jerboa-db peer)) + +(def test-count 0) +(def pass-count 0) +(def fail-count 0) + +(defrule (test name body ...) + (begin + (set! test-count (+ test-count 1)) + (display "RUN: ") (displayln name) + (flush-output-port (current-output-port)) + (guard (exn [#t (set! fail-count (+ fail-count 1)) + (displayln "FAIL: " name) + (display " Error: ") (display-condition exn) (newline) + (flush-output-port (current-output-port))]) + body ... + (set! pass-count (+ pass-count 1)) + (displayln "PASS: " name) + (flush-output-port (current-output-port))))) + +(defrule (assert-true expr) + (unless expr (error 'assert-true "Expected true"))) + +(defrule (assert-equal actual expected) + (let ([a actual] [e expected]) + (unless (equal? a e) + (error 'assert-equal (format "Expected ~s but got ~s" e a))))) + +(displayln "") +(displayln "=== Jerboa-DB Peer Client Tests (Round 9) ===") +(displayln "") + +;; ---- Helpers ---- + +(def (make-people-db) + (let ([conn (connect ":memory:")]) + (transact! conn + (list `((db/ident . person/name) + (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)) + `((db/ident . person/age) + (db/valueType . db.type/long) + (db/cardinality . db.cardinality/one)))) + (let ([t1 (tempid)] [t2 (tempid)]) + (transact! conn + (list `((db/id . ,t1) (person/name . "Alice") (person/age . 30)) + `((db/id . ,t2) (person/name . "Bob") (person/age . 25))))) + conn)) + +(def (make-orders-db) + (let ([conn (connect ":memory:")]) + (transact! conn + (list `((db/ident . order/sku) + (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)))) + (let ([t (tempid)]) + (transact! conn (list `((db/id . ,t) (order/sku . "BOOK-1"))))) + conn)) + +(def (warmup) + (sleep (chez-make-time 'time-duration 200000000 0))) + +;; ---- Group 1: core read/pull/entity ---- + +;; Single shared server across all groups — fiber-httpd on Termux is too flaky +;; to start/stop cleanly between groups. Use a fresh default DB and named +;; "orders" DB registered up front; tests are independent. + +(def default-conn (make-people-db)) +(def orders-conn (make-orders-db)) +(def shared-port 38770) +(def shared-srv (start-server (new-server-config default-conn shared-port))) +(register-db! "orders" orders-conn) +(warmup) + +(def peer (connect-remote (str "http://127.0.0.1:" shared-port))) +(def orders (connect-remote (str "http://127.0.0.1:" shared-port) "orders")) + +;; ---- Group 1: core read/pull/entity ---- + +(test "remote-connection?" + (assert-true (remote-connection? peer))) + +(test "remote-db returns alist with basis-tx" + (let ([s (remote-db peer)]) + (assert-true (pair? s)) + (assert-true (number? (cdr (assq 'basis-tx s)))))) + +(test "remote-q returns 2 names" + (let ([rows (remote-q peer '((find ?n) (where (?e person/name ?n))))]) + (assert-equal (length rows) 2))) + +(test "remote-pull on Alice" + (let* ([rows (remote-q peer '((find ?e) (where (?e person/name "Alice"))))] + [eid (car (car rows))] + [r (remote-pull peer '[*] eid)]) + (assert-equal (cdr (assq 'person/name r)) "Alice"))) + +(test "remote-entity on Bob (Phase 46)" + (let* ([rows (remote-q peer '((find ?e) (where (?e person/name "Bob"))))] + [eid (car (car rows))] + [ent (remote-entity peer eid)]) + (assert-equal (cdr (assq 'person/name ent)) "Bob"))) + +;; ---- Group 2: cache (Phase 49) ---- + +(test "cache miss then hit on identical remote-q" + (remote-cache-clear! peer) + (let ([rows1 (remote-q peer '((find ?n) (where (?e person/name ?n))))]) + (assert-equal (length rows1) 2) + (let ([rows2 (remote-q peer '((find ?n) (where (?e person/name ?n))))]) + (assert-equal rows1 rows2)) + (assert-equal (cdr (assq 'size (remote-cache-stats peer))) 1))) + +(test "cache stats reflect distinct queries" + (remote-cache-clear! peer) + (remote-q peer '((find ?n) (where (?e person/name ?n)))) + (remote-q peer '((find ?a) (where (?e person/age ?a)))) + (assert-equal (cdr (assq 'size (remote-cache-stats peer))) 2)) + +(test "cache capacity is tunable" + (remote-cache-set-capacity! peer 1) + (remote-cache-clear! peer) + (remote-q peer '((find ?n) (where (?e person/name ?n)))) + (remote-q peer '((find ?a) (where (?e person/age ?a)))) + (let ([sz (cdr (assq 'size (remote-cache-stats peer)))]) + (assert-true (<= sz 1)))) + +(test "remote-transact! advances last-tx" + (remote-cache-set-capacity! peer 256) + (let ([tx-before (cdr (assq 'last-tx (remote-cache-stats peer)))]) + (let ([t (tempid)]) + (remote-transact! peer + (list `((db/id . ,t) (person/name . "Carol") (person/age . 40))))) + (assert-true + (> (cdr (assq 'last-tx (remote-cache-stats peer))) tx-before)))) + +;; ---- Group 3: named-DB routing (Phase 47) ---- + +(test "named-DB connect retains db-name" + (assert-equal (remote-connection-db-name orders) "orders")) + +(test "named-DB remote-q sees only its data" + (let ([rows (remote-q orders '((find ?s) (where (?o order/sku ?s))))]) + (assert-equal (length rows) 1) + (assert-equal (caar rows) "BOOK-1"))) + +(test "named-DB remote-transact!" + (let ([tx-before (cdr (assq 'last-tx (remote-cache-stats orders)))] + [t (tempid)]) + (remote-transact! orders + (list `((db/id . ,t) (order/sku . "BOOK-2")))) + (assert-true + (> (cdr (assq 'last-tx (remote-cache-stats orders))) tx-before)))) + +(test "named DB and default DB are isolated" + (let ([orders-rows (remote-q orders '((find ?s) (where (?o order/sku ?s))))] + [default-rows (remote-q peer '((find ?n) (where (?e person/name ?n))))]) + (assert-equal (length orders-rows) 2) ;; BOOK-1 + BOOK-2 + (assert-equal (length default-rows) 3))) ;; Alice + Bob + Carol (added above) + +(stop-server shared-srv) + +;; ---- Summary ---- + +(displayln "") +(displayln (str "Results: " pass-count "/" test-count " passed, " + fail-count " failed")) +;; Force exit so the script terminates promptly even if a fiber-httpd +;; accept loop is still parked on a closed socket. +(exit (if (> fail-count 0) 1 0))