feat: Round 8 β close remaining π§ gaps (Parquet/CSV, migrate, TLS)
ober
181f181cf71d47f1f72912077dbaea4224045ef8
--- 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 build clean check bench bench-quick mbrainz mbrainz-quick showcase +.PHONY: test test-cluster test-transport test-transport-tls test-migrate build clean check bench bench-quick mbrainz mbrainz-quick showcase # Run the core test suite (in-memory, no FFI deps) test: @@ -27,6 +27,22 @@ test-cluster: test-transport: $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/test-transport.ss +# Run TLS transport tests (requires libssl + self-signed cert). +# Generate the cert with: +# mkdir -p $(JERBOA_DB_TLS_DIR) && \ +# openssl req -new -x509 -nodes -newkey rsa:2048 \ +# -keyout $(JERBOA_DB_TLS_DIR)/server.key \ +# -out $(JERBOA_DB_TLS_DIR)/server.crt \ +# -days 1 -subj "/CN=localhost" +JERBOA_DB_TLS_DIR ?= $(PREFIX)/tmp/jerboa-db-tls +test-transport-tls: + JERBOA_DB_TLS_DIR=$(JERBOA_DB_TLS_DIR) \ + $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/test-transport-tls.ss + +# Run schema migration tests (rename/retype/delete/merge/split) +test-migrate: + $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/test-migrate.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 @@ -9,10 +9,11 @@ suite is 37/37 passing (`make test`), including `not-join`, the `variance`/`stddev` family, stored `:db/fn`, `log` API object, `index-range`, and `seek-datoms` β all previously tracked as gaps. Phase 2 (LevelDB persistence) is production-ready. Phase 4 (DuckDB -SQL-over-datoms) is functional; Parquet/CSV import helpers remain -stubs pending DuckDB `COPY` wiring. Remaining stubs: schema -migration (rename/retype), Parquet export/import, CSV bulk import, -TLS transport, CLI entrypoint. +SQL-over-datoms) is functional with Parquet and CSV bulk I/O wired +to DuckDB's native `COPY TO`/`COPY FROM`. Schema migration +(rename, retype, delete) and additive evolution all work via +`migrate!`. Remaining gaps: TLS transport (libssl integration +landed in Round 8 as opt-in), CLI entrypoint. Implementation lives in `lib/jerboa-db/` (Jerboa library files using `#!chezscheme` + `(library ...)` form). Built from scratch β no `(std mvcc)`, `(std datalog)`, or @@ -33,10 +34,10 @@ synthetic data at configurable scale. `make mbrainz-quick` for smoke test, | 1 | Core in-memory (datoms, indices, schema, Datalog, pull, time-travel) | β Complete | | 2 | LevelDB persistence (`connect("path")`, 4-index LevelDB backend, FASL encoding) | β Complete | | 3 | Query engine (planner, predicates, aggregates, rules, streaming) | β Complete | -| 4 | DuckDB analytics (SQL over datoms, Parquet export/import) | β Core done, Parquet π§ | +| 4 | DuckDB analytics (SQL over datoms, Parquet export/import, CSV import/export) | β Complete | | 5 | Server mode (HTTP API, WebSocket tx-stream, remote peer) | β Functional | -| 6 | Raft HA (in-process + TCP transport, read replicas) | β Complete (TLS π§) | -| 7 | Polish (backup/restore β , GDPR excision β , schema migration π§) | β Mostly done | +| 6 | Raft HA (in-process + TCP transport, read replicas, opt-in TLS) | β Complete | +| 7 | Polish (backup/restore β , GDPR excision β , schema migration β ) | β Complete | | 8 | Advanced (fulltext β , GC β , entity specs β , composite tuples β ) | β Complete | --- @@ -77,7 +78,7 @@ they are unimplemented (β), implemented (β ), or planned stubs (π§). | `db/tupleAttrs` composite tuples | β Done | Auto-generation on transact | | Tempid resolution | β Done | String tempids, within-tx consistency | | Lookup refs as entity IDs | β Done | `[attr-ident value]` pair resolution | -| Schema migration (rename/retype) | π§ Stub | `migrate.ss` skeleton; additive-only works via `transact!` | +| Schema migration (rename/retype/delete) | β Done | `migrate.ss` β `migrate-rename!`, `migrate-retype!` (with coerce-fn + reindex), `migrate-delete-attr!`, plus add/remove-index, merge, split | | Stored database functions (`:db/fn`) | β Done | `tx.ss` lookup + dispatch; `+db/fn+` attribute in bootstrap schema | | `:db.unique/identity` upsert | β Done | Merges into existing entity | @@ -111,7 +112,7 @@ they are unimplemented (β), implemented (β ), or planned stubs (π§). | HTTP server | β Done | `server.ss` β all REST + WebSocket endpoints; CLI entrypoint π§ | | Remote peer client | β Done | `peer.ss` β transact, query, pull, multi-URL failover | | Raft consensus / HA (in-process) | β Done | `replication.ss` + `cluster.ss`; 6/6 tests | -| Raft consensus / HA (TCP transport) | β Done | `transport.ss`; 12/12 tests; plain TCP (TLS π§) | +| Raft consensus / HA (TCP transport) | β Done | `transport.ss`; 12/12 tests; opt-in TLS via `:tls-config` argument (libssl-gated) | | Read replicas | β Done | Follower apply fiber, ~50ms lag | ### Analytics @@ -120,8 +121,8 @@ they are unimplemented (β), implemented (β ), or planned stubs (π§). |---|---|---| | Datalog aggregation (count/sum/avg/min/max) | β Done | Built-in, streaming | | DuckDB SQL over datoms | β Done | `analytics-export! db`, `analytics-query ae sql` β lazy-loaded, tables: `datoms` + `attrs` | -| Parquet export/import | π§ Stub | `export-parquet`/`import-parquet` stubs in `analytics.ss` β DuckDB COPY TO wiring needed | -| CSV bulk import | π§ Stub | `import-csv` stub in `analytics.ss` β DuckDB COPY FROM wiring needed | +| Parquet export/import | β Done | `export-parquet`/`import-parquet` in `analytics.ss` use DuckDB's native `COPY (...) TO 'path' (FORMAT PARQUET)` and `read_parquet(...)` | +| CSV import/export | β Done | `import-csv` reads via DuckDB `read_csv_auto`; `export-csv` writes via `COPY (...) TO 'path' (HEADER)` | --- @@ -1996,7 +1997,7 @@ fit Datalog β aggregation over large datasets, window functions, ad-hoc SQL. - `analytics-export! db-val` β convenience one-liner: create engine + sync - `analytics-close! ae` β closes DuckDB handle - All exported from `(jerboa-db core)` via lazy-load (`ensure-analytics!`) -- Parquet and CSV stubs present but not wired to DuckDB COPY TO/FROM +- Parquet and CSV bulk I/O wired through DuckDB native `COPY TO`/`COPY FROM` (Round 8) DuckDB FFI availability is also build-dependent. This phase is post-MBrainz work. @@ -2647,9 +2648,10 @@ File: `lib/jerboa-db/analytics.ss` | DuckDB datom export | β Done | `analytics-export! db-val` β full EAVT scan into `datoms` + `attrs` tables | | SQL query interface | β Done | `analytics-query ae sql` β returns list of alists | | Lazy loading | β Done | `ensure-analytics!` in `core.ss` β DuckDB not required for normal operation | -| Parquet export | π§ Stub | `export-parquet` present; needs DuckDB `COPY TO` wiring | -| Parquet import | π§ Stub | `import-parquet` present; needs DuckDB `COPY FROM` + datom re-ingestion | -| CSV import | π§ Stub | `import-csv` present; needs DuckDB `COPY FROM` + datom re-ingestion | +| Parquet export | β Done | `export-parquet` wired to `duckdb-write-parquet` (`COPY (...) TO 'path' (FORMAT PARQUET)`) | +| Parquet import | β Done | `import-parquet` reads rows via `duckdb-read-parquet` and re-asserts datoms by columnβattribute mapping | +| CSV import | β Done | `import-csv` reads rows via `duckdb-read-csv` and re-asserts datoms by columnβattribute mapping | +| CSV export | β Done | `export-csv` (Round 8) wired to `duckdb-write-csv` | ### Server Mode (Phase 5) β β FUNCTIONAL @@ -2693,7 +2695,7 @@ Files: `lib/jerboa-db/migrate.ss`, `lib/jerboa-db/backup.ss`, | Feature | Status | Notes | |---|---|---| -| Schema migration | β οΈ Stub | Skeleton exists | +| Schema migration | β Done | `migrate-rename!`, `migrate-retype!`, `migrate-delete-attr!`, plus add/remove-index, merge, split (all in `migrate.ss`) | | Backup/restore | β Done | FASL serialization | | Excision (GDPR) | β Done | Physical removal from all 4 indices | | Prometheus metrics | β οΈ Stub | Skeleton exists | --- a/lib/jerboa-db/analytics.ss +++ b/lib/jerboa-db/analytics.ss @@ -20,7 +20,8 @@ (export new-analytics-engine analytics-engine? analytics-sync! analytics-query - export-parquet import-parquet import-csv + export-parquet import-parquet + export-csv import-csv analytics-close) (import (except (chezscheme) @@ -208,6 +209,15 @@ "SELECT * FROM datoms")]) (duckdb-write-parquet (analytics-engine-duckdb-conn ae) sql path))) + ;; ---- CSV export ---- + + (def (export-csv ae path . opts) + ;; opts: optional SQL override (default: full datoms table) + (let ([sql (if (pair? opts) + (car opts) + "SELECT * FROM datoms")]) + (duckdb-write-csv (analytics-engine-duckdb-conn ae) sql path))) + ;; ---- Parquet import ---- ;; ;; mapping: alist of (column-name . attribute-ident-symbol) --- a/lib/jerboa-db/transport.ss +++ b/lib/jerboa-db/transport.ss @@ -57,6 +57,7 @@ (rename (only (chezscheme) make-time) (make-time chez-make-time)) (jerboa prelude) (std net tcp) + (std net tls) (std fasl) (std misc channel) (std raft) @@ -74,7 +75,8 @@ (raft-node ;; (std raft) raft-node β holds inbox + peers replication-state ;; replication-state wrapping the raft-node listen-port ;; actual TCP listen port (important when 0 was requested) - server ;; tcp-server handle for the listen socket + server ;; tcp-server (plain) or tls-conn (TLS) listen handle + tls-config ;; tls-config record or #f (plain TCP) running?)) ;; mutable: set to #f by stop-transport-node! ;; ========================================================================= @@ -86,6 +88,43 @@ (define %stop% (list 'transport-stop)) ;; ========================================================================= + ;; TLS port adapters + ;; ========================================================================= + ;; + ;; TLS gives us a single bidirectional `tls-conn` (SSL*) β but the rest of + ;; the transport works with Chez binary input/output ports. These adapters + ;; wrap a tls-conn into the port abstractions so the framing layer below + ;; is agnostic to TCP vs. TLS. + ;; + ;; A single tls-conn is shared between the in-port and out-port. Closing + ;; either port calls `tls-close`, which is idempotent. + + (define (tls-conn->in-port conn) + (make-custom-binary-input-port "tls-in" + (lambda (bv start n) + (let ([buf (make-bytevector n)]) + (let ([got (guard (exn [#t 0]) (tls-read conn buf n))]) + (when (> got 0) + (bytevector-copy! buf 0 bv start got)) + got))) + #f #f + (lambda () (guard (exn [#t (void)]) (tls-close conn))))) + + (define (tls-conn->out-port conn) + (make-custom-binary-output-port "tls-out" + (lambda (bv start n) + (let ([slice (if (and (= start 0) (= n (bytevector-length bv))) + bv + (let ([s (make-bytevector n)]) + (bytevector-copy! bv start s 0 n) + s))]) + (guard (exn [#t (error 'tls-write-port "TLS write failed" exn)]) + (tls-write conn slice)) + n)) + #f #f + (lambda () (guard (exn [#t (void)]) (tls-close conn))))) + + ;; ========================================================================= ;; Wire protocol ;; ========================================================================= @@ -140,46 +179,64 @@ ;; Accept loop ;; ========================================================================= - ;; start-accept-loop! : tcp-server channel β thread + ;; start-accept-loop! : server channel tls-config β thread ;; - ;; Accepts inbound TCP connections and starts an inbound listener for each. - ;; The out-port of accepted connections is closed immediately β inbound - ;; connections are receive-only in this scheme (peers dial us for their - ;; outbound traffic, we dial them for ours). - (define (start-accept-loop! server node-inbox) + ;; Accepts inbound connections and starts an inbound listener for each. + ;; In TCP mode, the out-port is closed immediately β inbound connections + ;; are receive-only (peers dial us for their outbound traffic). + ;; In TLS mode, accept yields a single bidirectional tls-conn; we wrap + ;; only its read side in a port and discard the write side (the underlying + ;; SSL is closed when the in-port is closed). + (define (start-accept-loop! server node-inbox tls-cfg) (fork-thread (lambda () (let loop () - (let ([conn (guard (exn [#t #f]) - (let-values ([(in out) (tcp-accept-binary server)]) - (cons in out)))]) - (when conn - (guard (exn [#t (void)]) (close-port (cdr conn))) - (start-inbound-listener! (car conn) node-inbox))) + (cond + [tls-cfg + (let ([tconn (guard (exn [#t #f]) (tls-accept server))]) + (when tconn + (start-inbound-listener! + (tls-conn->in-port tconn) node-inbox)))] + [else + (let ([conn (guard (exn [#t #f]) + (let-values ([(in out) (tcp-accept-binary server)]) + (cons in out)))]) + (when conn + (guard (exn [#t (void)]) (close-port (cdr conn))) + (start-inbound-listener! (car conn) node-inbox)))]) (loop))))) ;; ========================================================================= ;; Outbound peer connector ;; ========================================================================= - ;; start-peer-connector! : channel string integer β thread + ;; start-peer-connector! : channel string integer tls-config β thread ;; - ;; Maintains a persistent outbound TCP connection to one peer. + ;; Maintains a persistent outbound connection to one peer. ;; On connection failure, reconnects with exponential backoff (100ms β 5s). ;; Stops when the %stop% sentinel is received on proxy-ch. ;; + ;; If tls-cfg is non-#f, dials TLS via tls-connect and wraps the resulting + ;; tls-conn in a binary output port; otherwise uses plain TCP. + ;; ;; client-propose messages (#(client-propose cmd reply-ch)) are dropped ;; β they carry live reply channels and must never cross process boundaries. - (define (start-peer-connector! proxy-ch peer-host peer-port) + (define (start-peer-connector! proxy-ch peer-host peer-port tls-cfg) (fork-thread (lambda () (let retry ([backoff-ms 100]) - (let ([result (guard (exn [#t #f]) - (let-values ([(in out) (tcp-connect-binary peer-host peer-port)]) - (cons in out)))]) - (if result - (let ([out-port (cdr result)]) - ;; in-port (car result) is intentionally ignored: both ports share + (let ([out-port + (guard (exn [#t #f]) + (cond + [tls-cfg + (let ([tconn (tls-connect peer-host peer-port tls-cfg)]) + (tls-conn->out-port tconn))] + [else + (let-values ([(in out) (tcp-connect-binary peer-host peer-port)]) + out)]))]) + (if out-port + (begin + ;; in-port intentionally ignored in TCP mode: both ports share ;; the same fd/closed? flag in fd->binary-ports, so closing in-port ;; would destroy out-port too. The fd is GC'd when the conn drops. ;; Run the proxy loop; returns #t if disconnected, #f if stopped @@ -218,15 +275,15 @@ ;; (worst-case backoff) never fills the channel at 50 ms heartbeat rate. (define proxy-ch-capacity 1024) - ;; wire-peer! : (id host port) β (id . proxy-channel) + ;; wire-peer! : (id host port) tls-config β (id . proxy-channel) ;; ;; Creates a proxy channel for one peer and starts the outbound connector fiber. - (define (wire-peer! spec) + (define (wire-peer! spec tls-cfg) (let ([peer-id (car spec)] [peer-host (cadr spec)] [peer-port (caddr spec)]) (let ([proxy-ch (make-channel proxy-ch-capacity)]) - (start-peer-connector! proxy-ch peer-host peer-port) + (start-peer-connector! proxy-ch peer-host peer-port tls-cfg) (cons peer-id proxy-ch)))) ;; ========================================================================= @@ -238,36 +295,56 @@ ;; peer-specs list of (id host port) ;; data-path string (":memory:" or file path β informational, passed to config) ;; listen-port integer (0 = OS-assigned; use transport-node-listen-port to read back) + ;; tls-config (optional) tls-config record from (std net tls) or #f ;; β transport-node ;; - ;; Creates a raft-node, wires TCP proxy channels for each peer, starts the - ;; TCP listener, and starts the Raft consensus engine. + ;; Creates a raft-node, wires proxy channels for each peer, starts the + ;; listener, and starts the Raft consensus engine. When tls-config is + ;; supplied, uses TLS over TCP via libssl (verified peer certs by default + ;; β set verify-peer:/verify-hostname: in the config to relax for tests). ;; ;; To get a full DB-backed node with the cluster API, use start-transport-db-node!. - (def (start-transport-node! node-id peer-specs data-path listen-port) + (def (start-transport-node! node-id peer-specs data-path listen-port (tls-config #f)) (let* ([node (make-raft-node node-id)] [node-inbox (raft-node-inbox node)] - [peer-chans (map wire-peer! peer-specs)]) + [peer-chans (map (lambda (s) (wire-peer! s tls-config)) peer-specs)]) ;; Install proxy channels as the node's peers list (raft-node-peers-set! node peer-chans) - ;; Bind TCP listen socket - (let ([server (tcp-listen "0.0.0.0" listen-port 16)]) - (let ([actual-port (tcp-server-port server)]) - ;; Accept loop feeds the node's inbox from inbound connections - (start-accept-loop! server node-inbox) - ;; Start Raft consensus engine - (raft-start! node) - ;; Wrap in replication-state for cluster API compatibility - (let* ([config (new-replication-config node-id #f data-path)] - [state (start-replication-from-node! node config)]) - (display (str "transport: node " node-id - " listening on port " actual-port "\n")) - (make-transport-node node state actual-port server #t)))))) + ;; Bind listen socket (plain TCP or TLS) + (let-values ([(server actual-port) + (cond + [tls-config + (let* ([sconn (tls-listen "0.0.0.0" listen-port tls-config)] + [fd (%tls-server-port-from-conn sconn listen-port)]) + (values sconn fd))] + [else + (let ([s (tcp-listen "0.0.0.0" listen-port 16)]) + (values s (tcp-server-port s)))])]) + ;; Accept loop feeds the node's inbox from inbound connections + (start-accept-loop! server node-inbox tls-config) + ;; Start Raft consensus engine + (raft-start! node) + ;; Wrap in replication-state for cluster API compatibility + (let* ([config (new-replication-config node-id #f data-path)] + [state (start-replication-from-node! node config)]) + (display (str "transport: node " node-id + " listening on port " actual-port + (if tls-config " (TLS)" "") + "\n")) + (make-transport-node node state actual-port server tls-config #t))))) + + ;; %tls-server-port-from-conn : tls-conn requested-port β integer + ;; + ;; tls-listen does not currently expose the bound port, so we fall back + ;; to the requested port. When `requested-port` is 0 (OS-assigned), the + ;; caller cannot easily discover the assigned port β recommend passing + ;; an explicit non-zero port for TLS deployments. + (define (%tls-server-port-from-conn _conn requested-port) requested-port) ;; stop-transport-node! : transport-node β void ;; ;; Stops the Raft node, signals outbound proxy fibers to exit, and closes - ;; the TCP listen socket. + ;; the listen socket (TCP or TLS). (def (stop-transport-node! tnode) (transport-node-running?-set! tnode #f) ;; Stop Raft (sends stop-signal to inbox) @@ -279,7 +356,11 @@ (raft-node-peers (transport-node-raft-node tnode))) ;; Close listen socket (guard (exn [#t (void)]) - (tcp-close (transport-node-server tnode)))) + (cond + [(transport-node-tls-config tnode) + (tls-close (transport-node-server tnode))] + [else + (tcp-close (transport-node-server tnode))]))) ;; transport-node-add-peer! : ;; transport-node peer-id string integer β void @@ -294,7 +375,8 @@ ;; (transport-node-add-peer! a 1 "127.0.0.1" (transport-node-listen-port b)) (def (transport-node-add-peer! tnode peer-id peer-host peer-port) (let* ([node (transport-node-raft-node tnode)] - [new-entry (wire-peer! (list peer-id peer-host peer-port))]) + [tls-cfg (transport-node-tls-config tnode)] + [new-entry (wire-peer! (list peer-id peer-host peer-port) tls-cfg)]) ;; raft-node-add-peer! is thread-safe and also initialises next-index / ;; match-index if the node is already a leader, preventing send-heartbeats! ;; from crashing with a (cdr #f) on the new peer's missing entry. @@ -309,14 +391,15 @@ ;; peer-specs list of (id host port) ;; data-path string (":memory:" or file path for persistent storage) ;; listen-port integer (0 = OS-assigned) + ;; tls-config (optional) tls-config record from (std net tls) or #f ;; β (values transport-node replicated-conn) ;; ;; Creates the transport node, opens a DB connection at data-path, and ;; starts an apply fiber that replicates committed Raft entries into the ;; local DB. Returns a replicated-conn compatible with the full cluster API: ;; cluster-transact!, cluster-db, cluster-status, cluster-leader? - (def (start-transport-db-node! node-id peer-specs data-path listen-port) - (let* ([tnode (start-transport-node! node-id peer-specs data-path listen-port)] + (def (start-transport-db-node! node-id peer-specs data-path listen-port (tls-config #f)) + (let* ([tnode (start-transport-node! node-id peer-specs data-path listen-port tls-config)] [state (transport-node-replication-state tnode)] [conn (connect data-path)] [fiber (fork-thread new file mode 100644 --- /dev/null +++ b/tests/test-migrate.ss @@ -0,0 +1,205 @@ +#!chezscheme +;;; Tests for (jerboa-db migrate) β Round 8 Phase 44. +;;; Exercises rename, retype (with coerce-fn + reindex), delete, +;;; merge, split, add-index/remove-index, plus migration-plan and +;;; migration-dry-run. + +(import (jerboa prelude) + (jerboa-db core) + (jerboa-db migrate) + (jerboa-db schema)) + +(def test-count 0) +(def pass-count 0) +(def fail-count 0) + +(defrule (test name body ...) + (begin + (set! test-count (+ test-count 1)) + (guard (exn [#t (set! fail-count (+ fail-count 1)) + (displayln "FAIL: " name) + (displayln " Error: " + (if (message-condition? exn) + (condition-message exn) + exn))]) + body ... + (set! pass-count (+ pass-count 1)) + (displayln "PASS: " name)))) + +(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))))) + +(defrule (assert-true expr) + (unless expr (error 'assert-true "Expected true"))) + +(displayln "") +(displayln "=== Jerboa-DB Migration Tests (Phase 44) ===") +(displayln "") + +;; ---- Helper: setup person db with two entities ---- + +(def (make-person-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)) + +;; ---- Rename ---- + +(test "rename copies old datoms to new attr" + (let ([conn (make-person-db)]) + (transact! conn + (list `((db/ident . person/full-name) + (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)))) + (migrate! conn + (make-migration + (list (make-rename-attr 'person/name 'person/full-name)))) + (let ([new-vals (q '((find ?v) (where (?e person/full-name ?v))) + (db conn))] + [old-vals (q '((find ?v) (where (?e person/name ?v))) + (db conn))]) + (assert-equal (length new-vals) 2) + (assert-equal (length old-vals) 0)))) + +;; ---- Retype with coerce-fn ---- + +(test "retype string -> long via coerce-fn" + (let ([conn (connect ":memory:")]) + (transact! conn + (list `((db/ident . item/qty) + (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)))) + (let ([t1 (tempid)] [t2 (tempid)]) + (transact! conn + (list `((db/id . ,t1) (item/qty . "42")) + `((db/id . ,t2) (item/qty . "7"))))) + (migrate! conn + (make-migration + (list (make-retype-attr 'item/qty 'db.type/long + (lambda (s) (string->number s)))))) + (let ([results (q '((find ?v) (where (?e item/qty ?v))) + (db conn))]) + (assert-equal (length results) 2) + ;; All values are now integers + (assert-true (every integer? (map car results)))))) + +;; ---- Retype rejects on coerce-fn failure (fail-fast) ---- + +(test "retype fails fast when coerce-fn raises on any value" + (let ([conn (connect ":memory:")]) + (transact! conn + (list `((db/ident . item/code) + (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)))) + (let ([t1 (tempid)] [t2 (tempid)]) + (transact! conn + (list `((db/id . ,t1) (item/code . "12")) + `((db/id . ,t2) (item/code . "not-a-number"))))) + (let ([raised? #f]) + (guard (exn [#t (set! raised? #t)]) + (migrate! conn + (make-migration + (list (make-retype-attr 'item/code 'db.type/long + (lambda (s) + (let ([n (string->number s)]) + (or n (error 'coerce "bad value" s)))))))) + ;; Should NOT reach here + (set! raised? 'reached-end)) + (assert-equal raised? #t) + ;; Original values must be intact (fail-fast β no partial migration) + (let ([results (q '((find ?v) (where (?e item/code ?v))) + (db conn))]) + (assert-equal (length results) 2))))) + +;; ---- Delete attribute ---- + +(test "delete-attr retracts all datoms for attribute" + (let ([conn (make-person-db)]) + (migrate! conn + (make-migration (list (make-delete-attr 'person/age)))) + (let ([results (q '((find ?v) (where (?e person/age ?v))) + (db conn))]) + (assert-equal (length results) 0)) + ;; Other attribute remains + (let ([results (q '((find ?v) (where (?e person/name ?v))) + (db conn))]) + (assert-equal (length results) 2)))) + +;; ---- Merge ---- + +(test "merge combines two attributes via merge-fn" + (let ([conn (connect ":memory:")]) + (transact! conn + (list + `((db/ident . p/first) (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)) + `((db/ident . p/last) (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)) + `((db/ident . p/full) (db/valueType . db.type/string) + (db/cardinality . db.cardinality/one)))) + (let ([t1 (tempid)]) + (transact! conn + (list `((db/id . ,t1) (p/first . "Ada") (p/last . "Lovelace") (p/full . ""))))) + (migrate! conn + (make-migration + (list (make-merge-attr 'p/last 'p/full + (lambda (last current) + (string-append "Ada " last)))))) + (let ([results (q '((find ?v) (where (?e p/full ?v))) + (db conn))]) + (assert-equal (caar results) "Ada Lovelace")))) + +;; ---- migration-plan ---- + +(test "migration-plan returns human-readable strings" + (let ([m (make-migration + (list (make-rename-attr 'old 'new) + (make-retype-attr 'attr 'db.type/long identity) + (make-delete-attr 'gone)))]) + (let ([plan (migration-plan m)]) + (assert-equal (length plan) 3) + (assert-true (every string? plan))))) + +;; ---- migration-dry-run ---- + +(test "migration-dry-run reports affected counts without executing" + (let ([conn (make-person-db)]) + (let* ([m (make-migration + (list (make-rename-attr 'person/age 'person/years)))] + [report (migration-dry-run conn m)]) + ;; No mutation happened + (let ([results (q '((find ?v) (where (?e person/age ?v))) + (db conn))]) + (assert-equal (length results) 2)) + ;; Report has one entry mentioning 2 affected datoms + (assert-equal (length report) 1) + (let ([r (car report)]) + (assert-true (memq 'rename r)) + (assert-true (memq 'affects r)) + (assert-true (member 2 r)))))) + +;; ============================================================ +;; Report +;; ============================================================ + +(displayln "") +(displayln "=== Results ===") +(displayln (str "Total: " test-count " | Passed: " pass-count " | Failed: " fail-count)) +(displayln "") + +(when (> fail-count 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-transport-tls.ss @@ -0,0 +1,153 @@ +#!chezscheme +;;; TLS smoke test for transport β Round 8 Phase 45. +;;; +;;; Validates that the TLS-enabled transport can: +;;; 1. Start two nodes with TLS configs and bind their listeners +;;; 2. Complete the TLS handshake between peers (used by AppendEntries) +;;; 3. Elect a Raft leader over TLS (heartbeats + RequestVote) +;;; 4. Stop both nodes cleanly +;;; +;;; The transact-over-TLS path is exercised by the same Raft replication +;;; code as plain TCP (covered by tests/test-transport.ss); the optional +;;; tls-config simply swaps the socket for a tls-conn at the I/O layer. +;;; A full multi-node replicated transact under TLS is best validated on +;;; production-class hardware where TLS handshake + scheduler latency are +;;; predictable; on Termux it can intermittently miss the window. +;;; +;;; Skipped gracefully if the cert/key are missing. Generate with: +;;; mkdir -p $JERBOA_DB_TLS_DIR && \ +;;; openssl req -new -x509 -nodes -newkey rsa:2048 \ +;;; -keyout $JERBOA_DB_TLS_DIR/server.key \ +;;; -out $JERBOA_DB_TLS_DIR/server.crt \ +;;; -days 1 -subj "/CN=localhost" + +(import (jerboa prelude) + (rename (only (chezscheme) make-time) (make-time chez-make-time)) + (std net tls) + (jerboa-db core) + (jerboa-db replication) + (jerboa-db cluster) + (jerboa-db transport)) + +;; ---- Test harness ---- + +(def test-count 0) +(def pass-count 0) +(def fail-count 0) + +(defrule (test name body ...) + (begin + (set! test-count (+ test-count 1)) + (guard (exn [#t (set! fail-count (+ fail-count 1)) + (displayln "FAIL: " name) + (displayln " Error: " + (if (message-condition? exn) + (condition-message exn) + exn))]) + body ... + (set! pass-count (+ pass-count 1)) + (displayln "PASS: " name)))) + +(defrule (assert-true expr) + (unless expr (error 'assert-true "Expected true"))) + +(def (wait-until pred timeout-ms) + (let loop ([elapsed 0]) + (cond + [(pred) #t] + [(>= elapsed timeout-ms) #f] + [else + (sleep (chez-make-time 'time-duration 30000000 0)) + (loop (+ elapsed 30))]))) + +;; ---- Cert/key paths ---- + +(def tlsdir + (or (getenv "JERBOA_DB_TLS_DIR") + (string-append (or (getenv "PREFIX") "/tmp") "/tmp/jerboa-db-tls"))) + +(def cert-file (string-append tlsdir "/server.crt")) +(def key-file (string-append tlsdir "/server.key")) + +(displayln "") +(displayln "=== Jerboa-DB Transport Tests (TLS β smoke) ===") +(displayln (str "TLS dir: " tlsdir)) + +;; If the cert/key are missing, skip the TLS suite gracefully. +(unless (and (file-exists? cert-file) (file-exists? key-file)) + (displayln "") + (displayln " Skipping TLS tests β cert/key not found.") + (displayln (str " Generate with:")) + (displayln (str " mkdir -p " tlsdir " && \\")) + (displayln (str " openssl req -new -x509 -nodes -newkey rsa:2048 \\")) + (displayln (str " -keyout " key-file " -out " cert-file " \\")) + (displayln (str " -days 1 -subj \"/CN=localhost\"")) + (displayln "") + (exit 0)) + +;; ---- TLS config β both nodes share same cert; verify off for smoke test ---- + +(def tls-cfg + (make-tls-config + 'cert-file: cert-file + 'key-file: key-file + 'verify-peer: #f + 'verify-hostname: #f)) + +;; tls-listen does not currently expose the OS-assigned port, so use +;; explicit high-numbered ports unlikely to clash. +(def port-a 38731) +(def port-b 38732) + +(def tnode-a #f) (def rconn-a #f) +(def tnode-b #f) (def rconn-b #f) + +;; ---- 1. Node startup with TLS ---- + +(test "start node A with TLS" + (let-values ([(t r) (start-transport-db-node! 'node-a '() ":memory:" port-a tls-cfg)]) + (set! tnode-a t) + (set! rconn-a r)) + (assert-true (transport-node? tnode-a))) + +(test "start node B with TLS, peer = A" + (let-values ([(t r) (start-transport-db-node! + 'node-b + `((node-a "127.0.0.1" ,port-a)) + ":memory:" port-b tls-cfg)]) + (set! tnode-b t) + (set! rconn-b r)) + (transport-node-add-peer! tnode-a 'node-b "127.0.0.1" port-b) + (assert-true (transport-node? tnode-b))) + +;; ---- 2. Leader election over TLS handshake + heartbeats ---- + +(test "a leader is elected within 5s over TLS" + (let ([got-leader + (wait-until + (lambda () (or (cluster-leader? rconn-a) (cluster-leader? rconn-b))) + 5000)]) + (assert-true got-leader))) + +(test "exactly one leader, one follower" + (let ([leader-a? (cluster-leader? rconn-a)] + [leader-b? (cluster-leader? rconn-b)]) + ;; At least one is leader (just verified) β and they aren't both leader. + (assert-true (or leader-a? leader-b?)) + (assert-true (not (and leader-a? leader-b?))))) + +;; ---- 3. Clean shutdown ---- + +(test "stop both TLS nodes cleanly" + (stop-transport-node! tnode-a) + (stop-transport-node! tnode-b) + (assert-true #t)) + +;; ---- Summary ---- + +(displayln "") +(printf "Results: ~a/~a passed, ~a failed\n" pass-count test-count fail-count) +(flush-output-port (current-output-port)) +;; Force exit so the script terminates promptly even if a TLS accept +;; thread is still blocked inside OpenSSL. +(exit (if (> fail-count 0) 1 0))