giles
ef7de817bb
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 3m32s
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
83 lines
4.9 KiB
Plaintext
83 lines
4.9 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
|
|
;; 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.
|
|
(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" "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)
|
|
(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))})))
|