giles
bac80f6c0b
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 17s
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 <noreply@anthropic.com>
89 lines
5.6 KiB
Plaintext
89 lines
5.6 KiB
Plaintext
;; lib/host/ledger.sx — the strangler migration ledger. A catalogue of every
|
|
;; rose-ash HTTP endpoint with its Quart original and its current host status, so
|
|
;; the cut-over from Quart to the SX host is tracked endpoint-by-endpoint rather
|
|
;; than big-bang. Status is one of:
|
|
;; :native — born on the host, has no Quart original (e.g. /health probe)
|
|
;; :migrated — moved off Quart, now served by an SX handler
|
|
;; :proxied — still on Quart; the host forwards until cut over
|
|
;; Coverage (how far the strangler has progressed = how much is OFF Quart) is
|
|
;; computed from the catalogue. Pure data + queries — no IO, fully conformable.
|
|
|
|
;; ── entry constructor ───────────────────────────────────────────────
|
|
;; quart is a "service:handler" ref string (nil for :native endpoints); handler
|
|
;; is the SX handler name serving it (nil while still :proxied).
|
|
(define host/ledger-entry
|
|
(fn (domain method path quart status handler)
|
|
{:domain domain :method method :path path
|
|
:quart quart :status status :handler handler}))
|
|
|
|
;; ── the catalogue ───────────────────────────────────────────────────
|
|
;; Reflects the live host: feed reads+writes migrated, /health native, the
|
|
;; 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/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)
|
|
(host/ledger-entry "likes" "POST" "/internal/actions/toggle" "likes:toggle" "proxied" nil)))
|
|
|
|
;; ── status / domain queries ─────────────────────────────────────────
|
|
(define host/ledger-by-status
|
|
(fn (ledger status) (filter (fn (e) (= (get e :status) status)) ledger)))
|
|
(define host/ledger-migrated (fn (ledger) (host/ledger-by-status ledger "migrated")))
|
|
(define host/ledger-proxied (fn (ledger) (host/ledger-by-status ledger "proxied")))
|
|
(define host/ledger-native (fn (ledger) (host/ledger-by-status ledger "native")))
|
|
(define host/ledger-by-domain
|
|
(fn (ledger domain) (filter (fn (e) (= (get e :domain) domain)) ledger)))
|
|
|
|
;; An endpoint is OFF Quart (served by the host) iff native or migrated.
|
|
(define host/ledger-served?
|
|
(fn (e) (or (= (get e :status) "native") (= (get e :status) "migrated"))))
|
|
|
|
;; First entry matching (method, path), or nil.
|
|
(define host/ledger-find
|
|
(fn (ledger method path)
|
|
(let ((hits (filter
|
|
(fn (e) (and (= (get e :method) method) (= (get e :path) path)))
|
|
ledger)))
|
|
(if (> (len hits) 0) (first hits) nil))))
|
|
|
|
;; Distinct domains in the catalogue (order: first-seen, reversed by cons).
|
|
(define host/ledger-domains
|
|
(fn (ledger)
|
|
(reduce
|
|
(fn (acc e)
|
|
(let ((d (get e :domain)))
|
|
(if (some (fn (x) (= x d)) acc) acc (cons d acc))))
|
|
(list)
|
|
ledger)))
|
|
|
|
;; ── coverage ────────────────────────────────────────────────────────
|
|
;; served = off Quart (migrated + native); percent = served / total, floored.
|
|
(define host/ledger-coverage
|
|
(fn (ledger)
|
|
(let ((total (len ledger))
|
|
(migrated (len (host/ledger-migrated ledger)))
|
|
(proxied (len (host/ledger-proxied ledger)))
|
|
(native (len (host/ledger-native ledger))))
|
|
{:total total
|
|
:migrated migrated
|
|
:proxied proxied
|
|
:native native
|
|
:served (+ migrated native)
|
|
:percent (if (= total 0) 0 (quotient (* 100 (+ migrated native)) total))})))
|