giles
999249b944
Greenfield SX-native pivot (NOT a strangler): the host speaks SX/SXTP end to end;
JSON only at the future ActivityPub federation edge.
- OUTPUT: host/json-status -> host/sx-status — every host/ok/host/error response is
text/sx via the serialize primitive (NOT application/json). Flips feed, relations,
blog reads. Tests assert the SX envelope ({:ok true :data ...}).
- DELETE the blog JSON CRUD /posts (POST/PUT/DELETE) + bearer-based host/blog--protect:
a pure old-contract REST mirror. Create/edit go through the HTML editor forms;
programmatic writes speak SXTP. FOLLOW-UP: no browser delete route yet (was JSON-only,
no UI) — add POST /:slug/delete + cascade edge cleanup when the metamodel UI needs it.
- INPUT: host/sx-body (sxtp.sx) parses a text/sx request body to a string-keyed dict
(parse-safe + sxtp/-normalize). feed POST + relations attach/detach read it.
- UNIFIED field reader host/fields / host/field: text/sx body OR urlencoded form by
content-type. The blog form handlers (new/edit/relate/unrelate) + login read through
it — additive, urlencoded still works (no-engine / bootstrap fallback).
Conformance 290/290 (11 suites). Retires the strangler framing in the plan; adds the
'SX all the way out' wire table. The engine half (browser posts text/sx) follows.
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
135 lines
6.7 KiB
Plaintext
135 lines
6.7 KiB
Plaintext
;; 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)))
|
|
|
|
;; ── 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.
|
|
;; Body is text/sx (host/sx-body); non-dict -> 400.
|
|
(define host/relations-attach
|
|
(fn (req)
|
|
(let ((p (host/sx-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.
|
|
;; Body is text/sx (host/sx-body); non-dict -> 400.
|
|
(define host/relations-detach
|
|
(fn (req)
|
|
(let ((p (host/sx-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)))))
|