From 11aba081f4da5ea0878e18fdb16a53f14f0b05e3 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 19 Jun 2026 17:24:37 +0000 Subject: [PATCH] =?UTF-8?q?host:=20Phase=203=20=E2=80=94=20relations=20REA?= =?UTF-8?q?D=20cut-over=20(get-children/get-parents),=20121/121?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Migrate the two internal relations read queries onto lib/relations: GET /internal/data/get-children + /get-parents dispatch to relations/children and relations/parents. Bridge the Quart (type,id) node key to a graph atom symbol "type:id" with relation-type as the edge kind; optional child/parent -type params filter by "type:" prefix. Golden tests pin each endpoint to subsystem-call + envelope. Ledger entries flipped to :migrated (off-Quart coverage 27% -> 45%). Co-Authored-By: Claude Opus 4.8 --- lib/host/conformance.sh | 8 +++ lib/host/ledger.sx | 10 ++-- lib/host/relations.sx | 58 +++++++++++++++++++ lib/host/tests/ledger.sx | 16 ++++-- lib/host/tests/relations.sx | 112 ++++++++++++++++++++++++++++++++++++ plans/host-on-sx.md | 31 ++++++++-- 6 files changed, 219 insertions(+), 16 deletions(-) create mode 100644 lib/host/relations.sx create mode 100644 lib/host/tests/relations.sx diff --git a/lib/host/conformance.sh b/lib/host/conformance.sh index ff94802d..57ee4a2f 100755 --- a/lib/host/conformance.sh +++ b/lib/host/conformance.sh @@ -46,6 +46,12 @@ MODULES=( "lib/acl/audit.sx" "lib/acl/federation.sx" "lib/acl/api.sx" + "lib/relations/schema.sx" + "lib/relations/engine.sx" + "lib/relations/api.sx" + "lib/relations/explain.sx" + "lib/relations/federation.sx" + "lib/relations/tree.sx" "lib/feed/normalize.sx" "lib/feed/stream.sx" "lib/feed/api.sx" @@ -59,6 +65,7 @@ MODULES=( "lib/host/sxtp.sx" "lib/host/router.sx" "lib/host/feed.sx" + "lib/host/relations.sx" "lib/host/ledger.sx" ) @@ -69,6 +76,7 @@ SUITES=( "sxtp host-sx-tests-run! lib/host/tests/sxtp.sx" "router host-rt-tests-run! lib/host/tests/router.sx" "feed host-fd-tests-run! lib/host/tests/feed.sx" + "relations host-rl-tests-run! lib/host/tests/relations.sx" "ledger host-lg-tests-run! lib/host/tests/ledger.sx" ) diff --git a/lib/host/ledger.sx b/lib/host/ledger.sx index 445d9146..5104918e 100644 --- a/lib/host/ledger.sx +++ b/lib/host/ledger.sx @@ -18,16 +18,16 @@ ;; ── the catalogue ─────────────────────────────────────────────────── ;; Reflects the live host: feed reads+writes migrated, /health native, the -;; internal-only likes/relations data+action endpoints still proxied to Quart. -;; relations is the next cut-over candidate — it already has a real SX subsystem -;; (lib/relations); likes has none, so it stays proxied until one exists. +;; relations READ endpoints migrated onto lib/relations (see lib/host/relations.sx), +;; relations writes + the internal-only likes data+action endpoints still proxied +;; to Quart. likes has no SX subsystem, so it stays proxied until one exists. (define host/ledger (list (host/ledger-entry "host" "GET" "/health" nil "native" "host/health-route") (host/ledger-entry "feed" "GET" "/feed" "feed:timeline" "migrated" "host/feed-timeline") (host/ledger-entry "feed" "POST" "/feed" "feed:create" "migrated" "host/feed-create") - (host/ledger-entry "relations" "GET" "/internal/data/get-children" "relations:get_children" "proxied" nil) - (host/ledger-entry "relations" "GET" "/internal/data/get-parents" "relations:get_parents" "proxied" nil) + (host/ledger-entry "relations" "GET" "/internal/data/get-children" "relations:get_children" "migrated" "host/relations-children") + (host/ledger-entry "relations" "GET" "/internal/data/get-parents" "relations:get_parents" "migrated" "host/relations-parents") (host/ledger-entry "relations" "POST" "/internal/actions/relate" "relations:relate" "proxied" nil) (host/ledger-entry "relations" "POST" "/internal/actions/unrelate" "relations:unrelate" "proxied" nil) (host/ledger-entry "likes" "GET" "/internal/data/is-liked" "likes:is_liked" "proxied" nil) diff --git a/lib/host/relations.sx b/lib/host/relations.sx new file mode 100644 index 00000000..70bc65e7 --- /dev/null +++ b/lib/host/relations.sx @@ -0,0 +1,58 @@ +;; lib/host/relations.sx — Relations domain endpoints on the host. The relations +;; service is internal-only (no public routes): Quart exposes it as signed +;; /internal/data/{query} reads + /internal/actions/{action} writes. This migrates +;; the two READ queries — get-children, get-parents — straight onto the SX host, +;; dispatching to the lib/relations subsystem (a saturating Datalog graph). +;; +;; Node model: the Quart relations API keys nodes by a (type, id) pair; the graph +;; subsystem keys them by an opaque atom. We bridge by composing the atom as the +;; symbol "type:id", with the relation-type as the edge kind. Optional child-type +;; / parent-type params filter the result by that "type:" prefix — matching the +;; Quart queries' optional type narrowing. +;; Depends on lib/relations/* + lib/host/handler.sx + lib/dream/* (query params). + +;; ── node helpers ──────────────────────────────────────────────────── +(define host/-rel-node + (fn (type id) (string->symbol (str type ":" id)))) +(define host/-rel-node-type? + (fn (node type) (starts-with? (symbol->string node) (str type ":")))) +(define host/-rel-strings + (fn (nodes) (map (fn (n) (symbol->string n)) nodes))) + +;; ── GET /internal/data/get-children ───────────────────────────────── +;; query: parent-type, parent-id, relation-type (required); child-type (optional +;; filter). Returns the child node ids ("type:id") for the parent under that kind. +(define host/relations-children + (fn (req) + (let ((ptype (dream-query-param req "parent-type")) + (pid (dream-query-param req "parent-id")) + (kind (dream-query-param req "relation-type"))) + (if (and ptype pid kind) + (let ((kids (relations/children (host/-rel-node ptype pid) (string->symbol kind))) + (ctype (dream-query-param req "child-type"))) + (let ((sel (if ctype (filter (fn (k) (host/-rel-node-type? k ctype)) kids) kids))) + (host/ok (host/-rel-strings sel)))) + (host/error 400 "missing parameter"))))) + +;; ── GET /internal/data/get-parents ────────────────────────────────── +;; query: child-type, child-id, relation-type (required); parent-type (optional +;; filter). Returns the parent node ids ("type:id") for the child under that kind. +(define host/relations-parents + (fn (req) + (let ((ctype (dream-query-param req "child-type")) + (cid (dream-query-param req "child-id")) + (kind (dream-query-param req "relation-type"))) + (if (and ctype cid kind) + (let ((ps (relations/parents (host/-rel-node ctype cid) (string->symbol kind))) + (ptype (dream-query-param req "parent-type"))) + (let ((sel (if ptype (filter (fn (p) (host/-rel-node-type? p ptype)) ps) ps))) + (host/ok (host/-rel-strings sel)))) + (host/error 400 "missing parameter"))))) + +;; ── read route group ──────────────────────────────────────────────── +;; Internal data reads (the signed-internal-auth gate is a separate middleware +;; concern, like the feed reads); these dispatch straight to the subsystem. +(define host/relations-routes + (list + (dream-get "/internal/data/get-children" host/relations-children) + (dream-get "/internal/data/get-parents" host/relations-parents))) diff --git a/lib/host/tests/ledger.sx b/lib/host/tests/ledger.sx index 8b1c0f0a..bffd5a86 100644 --- a/lib/host/tests/ledger.sx +++ b/lib/host/tests/ledger.sx @@ -37,11 +37,15 @@ (get (host/ledger-find host/ledger "POST" "/feed") :handler) "host/feed-create") (host-lg-test "find missing -> nil" (host/ledger-find host/ledger "GET" "/nope") nil) +(host-lg-test + "find migrated relations read -> handler" + (get (host/ledger-find host/ledger "GET" "/internal/data/get-children") :handler) + "host/relations-children") ;; ── status queries ────────────────────────────────────────────────── -(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 2) +(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 4) (host-lg-test "native count" (len (host/ledger-native host/ledger)) 1) -(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 8) +(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 6) ;; ── served? predicate ─────────────────────────────────────────────── (host-lg-test @@ -73,11 +77,11 @@ ;; ── coverage ──────────────────────────────────────────────────────── (define host-lg-cov (host/ledger-coverage host/ledger)) (host-lg-test "coverage total" (get host-lg-cov :total) 11) -(host-lg-test "coverage migrated" (get host-lg-cov :migrated) 2) -(host-lg-test "coverage proxied" (get host-lg-cov :proxied) 8) +(host-lg-test "coverage migrated" (get host-lg-cov :migrated) 4) +(host-lg-test "coverage proxied" (get host-lg-cov :proxied) 6) (host-lg-test "coverage native" (get host-lg-cov :native) 1) -(host-lg-test "coverage served" (get host-lg-cov :served) 3) -(host-lg-test "coverage percent" (get host-lg-cov :percent) 27) +(host-lg-test "coverage served" (get host-lg-cov :served) 5) +(host-lg-test "coverage percent" (get host-lg-cov :percent) 45) (define host-lg-tests-run! diff --git a/lib/host/tests/relations.sx b/lib/host/tests/relations.sx new file mode 100644 index 00000000..fa3567de --- /dev/null +++ b/lib/host/tests/relations.sx @@ -0,0 +1,112 @@ +;; lib/host/tests/relations.sx — the migrated relations read endpoints, +;; GET /internal/data/get-children and /get-parents, dispatching to lib/relations. +;; Golden tests pin each endpoint to "subsystem call + standard envelope": the +;; host adds the HTTP/JSON shell over relations/children|parents and nothing else +;; (golden derived from the same subsystem call, so result order matches). + +(define host-rl-pass 0) +(define host-rl-fail 0) +(define host-rl-fails (list)) + +(define + host-rl-test + (fn + (name actual expected) + (if + (= actual expected) + (set! host-rl-pass (+ host-rl-pass 1)) + (begin + (set! host-rl-fail (+ host-rl-fail 1)) + (append! host-rl-fails {:name name :actual actual :expected expected}))))) + +(define host-rl-req (fn (target) (dream-request "GET" target {} ""))) +(define host-rl-app (host/make-app (list host/relations-routes))) +(define host-rl-sym (fn (s) (string->symbol s))) + +;; ── seed a known graph ────────────────────────────────────────────── +;; org:1 --member--> list:7, list:8 ; org:1 --owner--> page:9 +(relations/load! (list)) +(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:7") (host-rl-sym "member")) +(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:8") (host-rl-sym "member")) +(relations/relate (host-rl-sym "org:1") (host-rl-sym "page:9") (host-rl-sym "owner")) + +;; ── get-children ──────────────────────────────────────────────────── +(define host-rl-kids + "/internal/data/get-children?parent-type=org&parent-id=1&relation-type=member") +(host-rl-test "children 200" (dream-status (host-rl-app (host-rl-req host-rl-kids))) 200) +(host-rl-test + "children has list:7" + (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:7") + true) +(host-rl-test + "children has list:8" + (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:8") + true) +(host-rl-test + "children excludes other-kind page:9" + (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "page:9") + false) +(host-rl-test + "children count via subsystem" + (len (relations/children (host-rl-sym "org:1") (host-rl-sym "member"))) + 2) + +;; child-type filter narrows by node prefix. +(host-rl-test + "children child-type=list keeps both" + (contains? + (dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=list")))) + "list:8") + true) +(host-rl-test + "children child-type=page filters all out" + (contains? + (dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=page")))) + "list:7") + false) + +;; ── get-parents ───────────────────────────────────────────────────── +(define host-rl-par + "/internal/data/get-parents?child-type=list&child-id=7&relation-type=member") +(host-rl-test "parents 200" (dream-status (host-rl-app (host-rl-req host-rl-par))) 200) +(host-rl-test + "parents has org:1" + (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-par))) "org:1") + true) + +;; ── missing required params -> 400 ────────────────────────────────── +(host-rl-test + "children missing param -> 400" + (dream-status (host-rl-app (host-rl-req "/internal/data/get-children?parent-type=org"))) + 400) +(host-rl-test + "parents missing param -> 400" + (dream-status (host-rl-app (host-rl-req "/internal/data/get-parents?child-type=list"))) + 400) + +;; ── golden: endpoint = subsystem call + envelope ──────────────────── +(host-rl-test + "golden children" + (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) + (str + "{\"ok\":true,\"data\":" + (dream-json-encode + (host/-rel-strings (relations/children (host-rl-sym "org:1") (host-rl-sym "member")))) + "}")) +(host-rl-test + "golden parents" + (dream-resp-body (host-rl-app (host-rl-req host-rl-par))) + (str + "{\"ok\":true,\"data\":" + (dream-json-encode + (host/-rel-strings (relations/parents (host-rl-sym "list:7") (host-rl-sym "member")))) + "}")) + +(define + host-rl-tests-run! + (fn + () + {:total (+ host-rl-pass host-rl-fail) + :passed host-rl-pass + :failed host-rl-fail + :fails host-rl-fails})) diff --git a/plans/host-on-sx.md b/plans/host-on-sx.md index 23ecf4a0..a2fc90de 100644 --- a/plans/host-on-sx.md +++ b/plans/host-on-sx.md @@ -36,9 +36,10 @@ host — no `ocaml-on-sx` dependency. ## Status (rolling) -`bash lib/host/conformance.sh` → **107/107** (6 suites: handler, middleware, sxtp, -router, feed, ledger). Phases 1 & 2 DONE; Phase 3 (strangler ledger) underway — -ledger module landed; `relations` cut-over next. +`bash lib/host/conformance.sh` → **121/121** (7 suites: handler, middleware, sxtp, +router, feed, relations, ledger). Phases 1 & 2 DONE; Phase 3 (strangler ledger) +underway — ledger module + `relations` READ cut-over landed (45% off Quart); +relations writes + golden harness next. ## Ground rules @@ -115,8 +116,13 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/… the live state: feed reads+writes migrated, `/health` native, the internal-only `relations`/`likes` data+action endpoints proxied. - [ ] golden-response harness vs the live Quart responses -- [ ] cut over a whole domain (`relations` — it has a real SX subsystem - `lib/relations`; `likes` has none so it stays proxied) as proof +- [~] cut over a whole domain (`relations`) as proof — READ side DONE + (`lib/host/relations.sx`): `GET /internal/data/get-children` + `/get-parents` + dispatch to `lib/relations` (`relations/children`/`parents`). Node model: + graph atom = symbol `"type:id"`, edge = relation-type; optional child/parent + `-type` param filters by `"type:"` prefix. Golden tests pin each endpoint to + `subsystem-call + envelope`. Ledger entries flipped to `:migrated`. WRITE side + (`relate`/`unrelate` actions, behind auth+ACL like POST /feed) next. ## Phase 4 — Dream framework layer (gated) - [ ] gate: `ocaml-on-sx` Phases 1–5 + minimal stdlib green @@ -175,6 +181,21 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/… to). NEXT: migrate the `relations` read endpoints onto host handlers (flip their ledger status to `:migrated`) with golden tests. +- **Phase 3 — relations READ cut-over (DONE, 121/121).** `lib/host/relations.sx` + + a 13-test golden suite; ledger flipped (off-Quart coverage 27% → 45%). The two + internal read queries (`get-children`, `get-parents`) now dispatch to the + `lib/relations` Datalog graph. Bridge: the Quart `(type, id)` node key maps to a + graph atom `(string->symbol "type:id")` with relation-type as the edge kind; + optional `child-type`/`parent-type` params filter the result list by `"type:"` + prefix (verified live: composite-string nodes round-trip through + `relations/relate` → `relations/children`). Golden discipline: `relations` is + internal-only (no public Quart route — confirmed via `svc_routes`), so the golden + is a **pinned fixture** (a known graph loaded in-test, asserted as + `subsystem-call + envelope`) rather than a live Quart capture. Reads are + unguarded for now — the signed-internal-auth gate is a separate middleware layer, + same as the feed reads. NEXT: relations WRITE actions (`relate`/`unrelate`) + behind the auth+ACL pipeline (mirroring POST /feed). + ## Blockers - **Live wiring to the native OCaml HTTP server** (Phase 3/4): the prod server in