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>
102 lines
4.5 KiB
Plaintext
102 lines
4.5 KiB
Plaintext
;; lib/host/tests/ledger.sx — the strangler migration ledger: entry shape,
|
|
;; status/domain queries, find, distinct domains, and coverage maths.
|
|
|
|
(define host-lg-pass 0)
|
|
(define host-lg-fail 0)
|
|
(define host-lg-fails (list))
|
|
|
|
(define
|
|
host-lg-test
|
|
(fn
|
|
(name actual expected)
|
|
(if
|
|
(= actual expected)
|
|
(set! host-lg-pass (+ host-lg-pass 1))
|
|
(begin
|
|
(set! host-lg-fail (+ host-lg-fail 1))
|
|
(append! host-lg-fails {:name name :actual actual :expected expected})))))
|
|
|
|
;; ── entry constructor ───────────────────────────────────────────────
|
|
(define host-lg-e (host/ledger-entry "feed" "GET" "/feed" "feed:timeline" "migrated" "host/feed-timeline"))
|
|
(host-lg-test "entry domain" (get host-lg-e :domain) "feed")
|
|
(host-lg-test "entry path" (get host-lg-e :path) "/feed")
|
|
(host-lg-test "entry status" (get host-lg-e :status) "migrated")
|
|
(host-lg-test "entry handler" (get host-lg-e :handler) "host/feed-timeline")
|
|
|
|
;; ── find ────────────────────────────────────────────────────────────
|
|
(host-lg-test
|
|
"find GET /feed -> migrated"
|
|
(get (host/ledger-find host/ledger "GET" "/feed") :status)
|
|
"migrated")
|
|
(host-lg-test
|
|
"find GET /feed -> handler"
|
|
(get (host/ledger-find host/ledger "GET" "/feed") :handler)
|
|
"host/feed-timeline")
|
|
(host-lg-test
|
|
"find POST /feed -> create"
|
|
(get (host/ledger-find host/ledger "POST" "/feed") :handler)
|
|
"host/feed-create")
|
|
(host-lg-test "find missing -> nil" (host/ledger-find host/ledger "GET" "/nope") nil)
|
|
(host-lg-test
|
|
"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)) 6)
|
|
(host-lg-test "native count" (len (host/ledger-native host/ledger)) 1)
|
|
(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 7)
|
|
|
|
;; ── served? predicate ───────────────────────────────────────────────
|
|
(host-lg-test
|
|
"served? migrated"
|
|
(host/ledger-served? (host/ledger-find host/ledger "GET" "/feed"))
|
|
true)
|
|
(host-lg-test
|
|
"served? native"
|
|
(host/ledger-served? (host/ledger-find host/ledger "GET" "/health"))
|
|
true)
|
|
(host-lg-test
|
|
"served? proxied false"
|
|
(host/ledger-served? (host/ledger-find host/ledger "POST" "/internal/actions/relate"))
|
|
false)
|
|
|
|
;; ── domain queries ──────────────────────────────────────────────────
|
|
(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
|
|
"domains has relations"
|
|
(some (fn (d) (= d "relations")) (host/ledger-domains host/ledger))
|
|
true)
|
|
(host-lg-test
|
|
"domains has feed"
|
|
(some (fn (d) (= d "feed")) (host/ledger-domains host/ledger))
|
|
true)
|
|
|
|
;; ── coverage ────────────────────────────────────────────────────────
|
|
(define host-lg-cov (host/ledger-coverage host/ledger))
|
|
(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) 7)
|
|
(host-lg-test "coverage percent" (get host-lg-cov :percent) 50)
|
|
|
|
(define
|
|
host-lg-tests-run!
|
|
(fn
|
|
()
|
|
{:total (+ host-lg-pass host-lg-fail)
|
|
:passed host-lg-pass
|
|
:failed host-lg-fail
|
|
:fails host-lg-fails}))
|