From bac80f6c0b2b2c0cde8f29ef37a6b74e673a8115 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 19 Jun 2026 17:30:45 +0000 Subject: [PATCH] =?UTF-8?q?host:=20Phase=203=20=E2=80=94=20relations=20WRI?= =?UTF-8?q?TE=20cut-over=20(attach/detach-child),=20132/132?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Migrate the container relations write actions onto lib/relations: POST /internal/actions/attach-child + /detach-child dispatch to relations/relate and relations/unrelate over the same "type:id" node model, behind the auth+ACL pipeline (wrap-errors . require-auth . require-permission), mirroring POST /feed. Closed-loop test: attach -> visible via get-children -> detach -> gone; 401/403/400 guards. Ledger now models the full relations surface (7 endpoints): container reads+writes migrated, typed relate/unrelate/can-relate proxied (registry+cardinality validation not in lib/relations). Off-Quart coverage 45% -> 50%. Co-Authored-By: Claude Opus 4.8 --- lib/host/ledger.sx | 20 ++++++---- lib/host/relations.sx | 74 +++++++++++++++++++++++++++++++++++++ lib/host/tests/ledger.sx | 24 ++++++++---- lib/host/tests/relations.sx | 68 ++++++++++++++++++++++++++++++++++ plans/host-on-sx.md | 39 ++++++++++++++----- 5 files changed, 200 insertions(+), 25 deletions(-) diff --git a/lib/host/ledger.sx b/lib/host/ledger.sx index 5104918e..f6a66f44 100644 --- a/lib/host/ledger.sx +++ b/lib/host/ledger.sx @@ -18,18 +18,24 @@ ;; ── the catalogue ─────────────────────────────────────────────────── ;; Reflects the live host: feed reads+writes migrated, /health native, the -;; 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. +;; relations container endpoints migrated onto lib/relations (reads get-children/ +;; get-parents + writes attach-child/detach-child — see lib/host/relations.sx). +;; The TYPED relations actions (relate/unrelate/can-relate) stay proxied: they +;; carry registry + cardinality validation lib/relations does not implement. The +;; internal-only likes data+action endpoints stay proxied too — likes has no SX +;; subsystem to dispatch to. (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" "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 "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/attach-child" "relations:attach_child" "migrated" "host/relations-attach") + (host/ledger-entry "relations" "POST" "/internal/actions/detach-child" "relations:detach_child" "migrated" "host/relations-detach") + (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 "relations" "POST" "/internal/actions/can-relate" "relations:can_relate" "proxied" nil) (host/ledger-entry "likes" "GET" "/internal/data/is-liked" "likes:is_liked" "proxied" nil) (host/ledger-entry "likes" "GET" "/internal/data/liked-slugs" "likes:liked_slugs" "proxied" nil) (host/ledger-entry "likes" "GET" "/internal/data/liked-ids" "likes:liked_ids" "proxied" nil) diff --git a/lib/host/relations.sx b/lib/host/relations.sx index 70bc65e7..4ed3fc30 100644 --- a/lib/host/relations.sx +++ b/lib/host/relations.sx @@ -56,3 +56,77 @@ (list (dream-get "/internal/data/get-children" host/relations-children) (dream-get "/internal/data/get-parents" host/relations-parents))) + +;; ── writes: container relations (attach-child / detach-child) ──────── +;; The write side of get-children/get-parents: a container edge between a parent +;; (type,id) and child (type,id) under a relation kind. Maps to relations/relate +;; and relations/unrelate over the same "type:id" node model, so an attach is +;; immediately visible through get-children. (The TYPED relate/unrelate/can-relate +;; actions stay on Quart — they carry registry + cardinality validation that +;; lib/relations does not implement.) Body is the action's JSON params dict. + +;; Pull the four node coordinates + kind from a payload; nil if any are absent. +(define host/-rel-edge + (fn (p) + (let ((pt (get p :parent-type)) (pid (get p :parent-id)) + (ct (get p :child-type)) (cid (get p :child-id)) + (kind (get p :relation-type))) + (if (and pt pid ct cid kind) + {:parent (host/-rel-node pt pid) + :child (host/-rel-node ct cid) + :kind (string->symbol kind) + :parent-id (str pt ":" pid) + :child-id (str ct ":" cid) + :relation kind} + nil)))) + +;; POST /internal/actions/attach-child — create the container edge. 201 on success. +(define host/relations-attach + (fn (req) + (let ((p (dream-json-body req))) + (if (= (type-of p) "dict") + (let ((e (host/-rel-edge p))) + (if e + (begin + (relations/relate (get e :parent) (get e :child) (get e :kind)) + (host/ok-status 201 + {:parent (get e :parent-id) :child (get e :child-id) + :relation (get e :relation)})) + (host/error 400 "missing parameter"))) + (host/error 400 "invalid payload"))))) + +;; POST /internal/actions/detach-child — remove the container edge. 200 on success. +(define host/relations-detach + (fn (req) + (let ((p (dream-json-body req))) + (if (= (type-of p) "dict") + (let ((e (host/-rel-edge p))) + (if e + (begin + (relations/unrelate (get e :parent) (get e :child) (get e :kind)) + (host/ok + {:parent (get e :parent-id) :child (get e :child-id) + :relation (get e :relation) :detached true})) + (host/error 400 "missing parameter"))) + (host/error 400 "invalid payload"))))) + +;; Guarded write route group: each action behind auth + ACL. attach needs +;; ("relate","relations"); detach needs ("unrelate","relations"). resolve is the +;; injected token->principal auth policy (same shape as host/feed-write-routes). +(define host/relations-write-routes + (fn (resolve) + (list + (dream-post "/internal/actions/attach-child" + (host/pipeline + (list + host/wrap-errors + (host/require-auth resolve) + (host/require-permission "relate" (fn (req) "relations"))) + host/relations-attach)) + (dream-post "/internal/actions/detach-child" + (host/pipeline + (list + host/wrap-errors + (host/require-auth resolve) + (host/require-permission "unrelate" (fn (req) "relations"))) + host/relations-detach))))) diff --git a/lib/host/tests/ledger.sx b/lib/host/tests/ledger.sx index bffd5a86..d2c3b628 100644 --- a/lib/host/tests/ledger.sx +++ b/lib/host/tests/ledger.sx @@ -41,11 +41,19 @@ "find migrated relations read -> handler" (get (host/ledger-find host/ledger "GET" "/internal/data/get-children") :handler) "host/relations-children") +(host-lg-test + "find migrated relations write -> handler" + (get (host/ledger-find host/ledger "POST" "/internal/actions/attach-child") :handler) + "host/relations-attach") +(host-lg-test + "typed relate still proxied" + (get (host/ledger-find host/ledger "POST" "/internal/actions/relate") :status) + "proxied") ;; ── status queries ────────────────────────────────────────────────── -(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 4) +(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 6) (host-lg-test "native count" (len (host/ledger-native host/ledger)) 1) -(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 6) +(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 7) ;; ── served? predicate ─────────────────────────────────────────────── (host-lg-test @@ -62,7 +70,7 @@ false) ;; ── domain queries ────────────────────────────────────────────────── -(host-lg-test "relations domain count" (len (host/ledger-by-domain host/ledger "relations")) 4) +(host-lg-test "relations domain count" (len (host/ledger-by-domain host/ledger "relations")) 7) (host-lg-test "likes domain count" (len (host/ledger-by-domain host/ledger "likes")) 4) (host-lg-test "domains count" (len (host/ledger-domains host/ledger)) 4) (host-lg-test @@ -76,12 +84,12 @@ ;; ── 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) 4) -(host-lg-test "coverage proxied" (get host-lg-cov :proxied) 6) +(host-lg-test "coverage total" (get host-lg-cov :total) 14) +(host-lg-test "coverage migrated" (get host-lg-cov :migrated) 6) +(host-lg-test "coverage proxied" (get host-lg-cov :proxied) 7) (host-lg-test "coverage native" (get host-lg-cov :native) 1) -(host-lg-test "coverage served" (get host-lg-cov :served) 5) -(host-lg-test "coverage percent" (get host-lg-cov :percent) 45) +(host-lg-test "coverage served" (get host-lg-cov :served) 7) +(host-lg-test "coverage percent" (get host-lg-cov :percent) 50) (define host-lg-tests-run! diff --git a/lib/host/tests/relations.sx b/lib/host/tests/relations.sx index fa3567de..90d265b6 100644 --- a/lib/host/tests/relations.sx +++ b/lib/host/tests/relations.sx @@ -102,6 +102,74 @@ (host/-rel-strings (relations/parents (host-rl-sym "list:7") (host-rl-sym "member")))) "}")) +;; ── writes: attach-child / detach-child (auth + ACL + closed loop) ── +(acl/load! + (list + (acl-grant "carol" "relate" "relations") + (acl-grant "carol" "unrelate" "relations"))) +;; carol is permitted; dave authenticates but has no grant. +(define host-rl-resolve + (fn (tok) + (cond ((= tok "good") "carol") ((= tok "weak") "dave") (true nil)))) +(define host-rl-wapp + (host/make-app + (list host/relations-routes (host/relations-write-routes host-rl-resolve)))) +(define host-rl-post + (fn (action auth body) + (dream-request "POST" (str "/internal/actions/" action) + (if auth {:authorization auth} {}) body))) +(define host-rl-edge + "{\"parent-type\":\"org\",\"parent-id\":\"2\",\"child-type\":\"list\",\"child-id\":\"5\",\"relation-type\":\"member\"}") +(define host-rl-org2 + "/internal/data/get-children?parent-type=org&parent-id=2&relation-type=member") + +(relations/load! (list)) + +;; auth gate +(host-rl-test + "attach no auth -> 401" + (dream-status (host-rl-wapp (host-rl-post "attach-child" nil "{}"))) + 401) +(host-rl-test + "attach authed-but-unpermitted -> 403" + (dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer weak" host-rl-edge))) + 403) +(host-rl-test + "graph unchanged after 403" + (len (relations/children (host-rl-sym "org:2") (host-rl-sym "member"))) + 0) + +;; permitted attach -> 201, and visible through the migrated read +(host-rl-test + "attach authed+permitted -> 201" + (dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" host-rl-edge))) + 201) +(host-rl-test + "attached edge visible via get-children" + (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5") + true) + +;; detach -> 200, and gone from the read +(host-rl-test + "detach authed+permitted -> 200" + (dream-status (host-rl-wapp (host-rl-post "detach-child" "Bearer good" host-rl-edge))) + 200) +(host-rl-test + "detached edge gone from get-children" + (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5") + false) + +;; bad payloads +(host-rl-test + "attach non-object body -> 400" + (dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" "[1,2]"))) + 400) +(host-rl-test + "attach missing param -> 400" + (dream-status + (host-rl-wapp (host-rl-post "attach-child" "Bearer good" "{\"parent-type\":\"org\"}"))) + 400) + (define host-rl-tests-run! (fn diff --git a/plans/host-on-sx.md b/plans/host-on-sx.md index a2fc90de..8e3f5814 100644 --- a/plans/host-on-sx.md +++ b/plans/host-on-sx.md @@ -36,10 +36,10 @@ host — no `ocaml-on-sx` dependency. ## Status (rolling) -`bash lib/host/conformance.sh` → **121/121** (7 suites: handler, middleware, sxtp, +`bash lib/host/conformance.sh` → **132/132** (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. +underway — ledger module + `relations` container cut-over landed (reads + guarded +writes, 50% off Quart). Golden-response harness vs live Quart next. ## Ground rules @@ -116,13 +116,15 @@ 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`) 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. +- [x] cut over a whole domain (`relations`) as proof — the CONTAINER relations are + fully on the host (`lib/host/relations.sx`): reads `GET .../get-children` + + `/get-parents` → `relations/children`/`parents`; writes `POST + .../attach-child` + `/detach-child` → `relations/relate`/`unrelate`, behind + the auth+ACL pipeline (mirrors POST /feed). Node model: graph atom = symbol + `"type:id"`, edge = relation-type; `child`/`parent-type` params filter by + `"type:"` prefix. Closed-loop test: attach → visible via get-children → + detach → gone. The TYPED actions (`relate`/`unrelate`/`can-relate`) stay + proxied by design — registry + cardinality validation lib/relations lacks. ## Phase 4 — Dream framework layer (gated) - [ ] gate: `ocaml-on-sx` Phases 1–5 + minimal stdlib green @@ -196,6 +198,23 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/… same as the feed reads. NEXT: relations WRITE actions (`relate`/`unrelate`) behind the auth+ACL pipeline (mirroring POST /feed). +- **Phase 3 — relations WRITE cut-over (DONE, 132/132).** `lib/host/relations.sx` + gains `host/relations-attach`/`-detach` (`POST .../attach-child` + `/detach-child`) + and `host/relations-write-routes` — the write side of the container reads, + dispatching to `relations/relate`/`unrelate` over the same `"type:id"` node + model so an attach is immediately visible through `get-children`. Each runs + behind the host pipeline `wrap-errors ∘ require-auth ∘ require-permission` + (`"relate"`/`"unrelate"` on `"relations"`) — exactly the POST /feed stack. The + relations test suite proves the closed loop end-to-end: 401 unauth, 403 authed- + but-unpermitted (graph unchanged), 201 attach → child visible via the migrated + read → 200 detach → child gone; 400 on bad/short payloads. The ledger now models + the full relations surface (7 endpoints): container reads+writes `:migrated`, + typed `relate`/`unrelate`/`can-relate` `:proxied` (registry/cardinality + validation not in lib/relations). Off-Quart coverage 45% → **50%** (7/14). + `relations` is the first whole *coherent feature* (container relations) fully + off Quart. NEXT: golden-response harness vs live Quart, then survey the next + domain (blog/likes proxied — likes needs an SX subsystem first). + ## Blockers - **Live wiring to the native OCaml HTTP server** (Phase 3/4): the prod server in