giles
e2a90e3bbd
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 15s
lib/host/blog.sx serves blog posts as HTML at GET /<slug>/ (the original strangler target, Quart blog post_detail). A post is a content-on-sx CtDoc rendered via content/html; anonymous + world-visible. In-memory slug->doc registry now (host/blog-lookup swappable for a persist-backed content stream later, handler/route unchanged). :slug catch-all mounted LAST so /feed, /health, /internal/* take precedence. Needs the Smalltalk+persist+content preload chain + (st-bootstrap-classes!)+(content/bootstrap!) — blog.sx self-bootstraps at load. serve.sh loads the chain + seeds a welcome post. Ledger gains the migrated blog post-detail (off-Quart 50% -> 53%). LIVE: blog.rose-ash.com/welcome/ renders real HTML through Cloudflare->Caddy; /feed still JSON (precedence verified), unknown slug 404. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
107 lines
4.6 KiB
Plaintext
107 lines
4.6 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")
|
|
|
|
(host-lg-test
|
|
"find migrated blog post -> handler"
|
|
(get (host/ledger-find host/ledger "GET" "/:slug") :handler)
|
|
"host/blog-post")
|
|
|
|
;; ── status queries ──────────────────────────────────────────────────
|
|
(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 7)
|
|
(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)) 5)
|
|
(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) 15)
|
|
(host-lg-test "coverage migrated" (get host-lg-cov :migrated) 7)
|
|
(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) 8)
|
|
(host-lg-test "coverage percent" (get host-lg-cov :percent) 53)
|
|
|
|
(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}))
|