rose-ash/lib/host/relations.sx

;; 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.
(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)))))