giles
db4809b01e
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Two engine fixes in web/orchestration.sx (rebuilt into the WASM bytecode) plus the blog CSS that surfaces them. 1. Retry on NETWORK failure, not just HTTP errors. The fetch error/catch path (the real offline / DNS / connection-refused case) previously dispatched sx:requestError and stopped — only a non-ok HTTP response with an empty body ever reached handle-retry. So "no connection" never recovered. Now the catch path calls handle-retry too, so an sx-retry element actually self-heals when the connection returns (the cap bounds the backoff interval, not the attempt count — it retries forever). 2. Visible failure state. On any failed/aborted fetch the engine adds an `.sx-error` class to the element (cleared, with the retry backoff reset, on the next success). Without it a stuck retry loop is invisible — the picker just sits "Loading…". The blog shell ships CSS so the relate picker shows "Connection problem — retrying…" / "offline, retrying…" on .sx-error. Platform-wide: any sx-get/sx-post element benefits, not just the picker. Tests: relate-picker.spec.js gains a 6th case — abort relate-options, assert .sx-error appears, un-abort, assert it clears and the picker repopulates (proving the retry loop is live). 6/6 browser + 272/272 conformance. WASM web stack rebuilt (orchestration.sxbc + the static hs-* copies refreshed by the same build). Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
1026 lines
52 KiB
Plaintext
1026 lines
52 KiB
Plaintext
;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model.
|
||
;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup
|
||
;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx
|
||
;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored
|
||
;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)`
|
||
;; — server-side, static, no client runtime needed to view a published post.
|
||
;;
|
||
;; GET / HTML index of posts (public)
|
||
;; GET /<slug>/ rendered post (public) -> HTML / 404
|
||
;; GET /posts JSON list (public) -> [{slug,title,status}]
|
||
;; GET /new HTML create form (public chrome)
|
||
;; POST /new form-urlencoded ingest from the editor (guarded)
|
||
;; POST /posts JSON create (guarded)
|
||
;; PUT /posts/<slug> JSON update (guarded)
|
||
;; DELETE /posts/<slug> delete (guarded)
|
||
;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog").
|
||
;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
|
||
;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
|
||
|
||
;; ── store (durable persist KV, injectable) ──────────────────────────
|
||
(define host/blog-store (persist/open))
|
||
(define host/blog-use-store! (fn (b) (set! host/blog-store b)))
|
||
(define host/blog--key (fn (slug) (str "blog:" slug)))
|
||
|
||
;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.)
|
||
(define host/blog-slugify
|
||
(fn (title)
|
||
(join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " ")))))
|
||
|
||
;; ── records ─────────────────────────────────────────────────────────
|
||
(define host/blog-get
|
||
(fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
|
||
(define host/blog-exists?
|
||
(fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug))))
|
||
(define host/blog-put!
|
||
(fn (slug title sx-content status)
|
||
(persist/backend-kv-put host/blog-store (host/blog--key slug)
|
||
{:slug slug :title title :sx-content sx-content :status status})))
|
||
(define host/blog-delete!
|
||
(fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
|
||
(define host/blog-seed!
|
||
(fn (slug title sx-content status)
|
||
(when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
|
||
|
||
;; all blog slugs (kv keys are "blog:<slug>")
|
||
(define host/blog-slugs
|
||
(fn ()
|
||
(reduce
|
||
(fn (acc k)
|
||
(if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
|
||
(list)
|
||
(persist/backend-kv-keys host/blog-store))))
|
||
(define host/blog-list
|
||
(fn ()
|
||
(map
|
||
(fn (slug)
|
||
(let ((r (host/blog-get slug)))
|
||
{:slug slug :title (get r :title) :status (get r :status)}))
|
||
(host/blog-slugs))))
|
||
|
||
;; ── render ──────────────────────────────────────────────────────────
|
||
;; A post's sx_content is SX element markup -> HTML via render-page (which supplies
|
||
;; the server env so components resolve + keyword attrs are kept).
|
||
;;
|
||
;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment
|
||
;; of blocks, some of which the host can't render (the legacy editor emits bare
|
||
;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over
|
||
;; with aliases). Rendering each block under its own guard means the real prose
|
||
;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder —
|
||
;; and a bad block never crashes the handler (-> 502).
|
||
(define host/blog--render-node
|
||
(fn (node)
|
||
(guard (e (true "<div class=\"blk-unsupported\"><em>(unsupported block)</em></div>"))
|
||
(render-page node))))
|
||
(define host/blog-render
|
||
(fn (record)
|
||
(let ((sx (get record :sx-content)))
|
||
(if (and sx (not (= sx "")))
|
||
(let ((tree (parse-safe sx)))
|
||
(cond
|
||
((nil? tree) "<p><em>(unparseable content)</em></p>")
|
||
((and (= (type-of tree) "list") (> (len tree) 0)
|
||
(= (str (first tree)) "<>"))
|
||
(join "" (map host/blog--render-node (rest tree))))
|
||
(else (host/blog--render-node tree))))
|
||
(str "<p>(empty post)</p>")))))
|
||
;; ── related posts (blog × relations) ────────────────────────────────
|
||
;; Every link between posts is a typed edge in the relations graph (lib/relations):
|
||
;; node = "blog:<slug>", kind = a relation kind. "related" is symmetric; directed
|
||
;; kinds (is-a, tagged) carry meaning by direction. The registry below is the one
|
||
;; place that knows each kind's direction, label, and candidate set — relate, the
|
||
;; picker, and rendering all read from it (see plans/typed-posts-and-relations.md).
|
||
;; "Typing is just relating to a type": classification is an is-a/tagged edge to a
|
||
;; type-post, and types ARE posts (same blog:<slug> namespace).
|
||
(define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))
|
||
|
||
(define host/blog-rel-kinds
|
||
(list
|
||
{:kind "related" :label "Related posts" :symmetric true :candidates "all"}
|
||
{:kind "is-a" :label "Types" :symmetric false :candidates "types"
|
||
:inverse-label "Instances"}
|
||
{:kind "subtype-of" :label "Subtype of" :symmetric false :candidates "types"
|
||
:inverse-label "Subtypes"}
|
||
{:kind "tagged" :label "Tags" :symmetric false :candidates "tags"
|
||
:inverse-label "Tagged with this"}))
|
||
|
||
;; registry lookup; nil for an unknown kind (relate validates against this)
|
||
(define host/blog--kind-spec
|
||
(fn (kind)
|
||
(reduce (fn (acc k) (if (= (get k :kind) kind) k acc)) nil host/blog-rel-kinds)))
|
||
(define host/blog--kind-symmetric?
|
||
(fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric)))))
|
||
|
||
;; ── edges (parameterised by kind, DURABLE) ──────────────────────────
|
||
;; lib/relations holds the graph in memory (a Datalog cache that re-saturates per
|
||
;; query); it does NOT survive a restart. So the host owns the durable source of
|
||
;; truth: every physical edge is also a KV row "edge:<src>|<kind>|<dst>" in the
|
||
;; blog store, replayed into the in-memory graph on boot (host/blog-load-edges!).
|
||
;; '|' is a safe delimiter — slugs are [a-z0-9-], kinds are registry names.
|
||
(define host/blog--edge-key (fn (src kind dst) (str "edge:" src "|" kind "|" dst)))
|
||
|
||
(define host/blog--add-edge!
|
||
(fn (src dst kind)
|
||
(begin
|
||
(relations/relate (host/blog--node src) (host/blog--node dst) (string->symbol kind))
|
||
(persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1))))
|
||
(define host/blog--del-edge!
|
||
(fn (src dst kind)
|
||
(begin
|
||
(relations/unrelate (host/blog--node src) (host/blog--node dst) (string->symbol kind))
|
||
(persist/backend-kv-delete host/blog-store (host/blog--edge-key src kind dst)))))
|
||
|
||
;; A symmetric kind writes both directions, so children alone read it from either
|
||
;; side; a directed kind writes one edge (the inverse is host/blog-in).
|
||
(define host/blog-relate!
|
||
(fn (a b kind)
|
||
(begin
|
||
(host/blog--add-edge! a b kind)
|
||
(when (host/blog--kind-symmetric? kind) (host/blog--add-edge! b a kind)))))
|
||
(define host/blog-unrelate!
|
||
(fn (a b kind)
|
||
(begin
|
||
(host/blog--del-edge! a b kind)
|
||
(when (host/blog--kind-symmetric? kind) (host/blog--del-edge! b a kind)))))
|
||
|
||
;; rebuild the in-memory graph from the durable edge store — called on boot, after
|
||
;; the store is pointed at the durable backend. Each "edge:<src>|<kind>|<dst>" key
|
||
;; is re-applied directly (both directions of a symmetric kind are stored, so no
|
||
;; symmetry re-derivation is needed here).
|
||
(define host/blog-load-edges!
|
||
(fn ()
|
||
(for-each
|
||
(fn (key)
|
||
(let ((body (substr key 5))) ;; drop "edge:"
|
||
(let ((p1 (index-of body "|")))
|
||
(when (>= p1 0)
|
||
(let ((src (substr body 0 p1))
|
||
(tail (substr body (+ p1 1))))
|
||
(let ((p2 (index-of tail "|")))
|
||
(when (>= p2 0)
|
||
(relations/relate
|
||
(host/blog--node src)
|
||
(host/blog--node (substr tail (+ p2 1)))
|
||
(string->symbol (substr tail 0 p2))))))))))
|
||
(filter (fn (k) (starts-with? k "edge:"))
|
||
(persist/backend-kv-keys host/blog-store)))))
|
||
|
||
;; nodes -> existing blog slugs: strip "blog:", drop non-blog and deleted targets.
|
||
;; Existence is one kv-keys read (host/blog-slugs), NOT a perform per candidate —
|
||
;; keeping IO out of the inner filter (and out of the page-render quasiquote).
|
||
(define host/blog--edge-slugs
|
||
(fn (nodes)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
|
||
|
||
;; DIRECT edges come from the durable edge store, NOT lib/relations: each relations
|
||
;; query re-runs the (CEK-interpreted) ruleset — ~seconds even on a tiny graph —
|
||
;; whereas the edge:<src>|<kind>|<dst> KV rows are a cheap string scan. lib/relations
|
||
;; is reserved for TRANSITIVE queries (descendants/ancestors). The two are always
|
||
;; in sync: host/blog-relate! writes both, and a plain blog edge has no derived
|
||
;; effective edges, so KV == relations/children for direct lookups.
|
||
(define host/blog--parse-edge-key
|
||
(fn (k)
|
||
(if (starts-with? k "edge:")
|
||
(let ((body (substr k 5)))
|
||
(let ((p1 (index-of body "|")))
|
||
(if (< p1 0) nil
|
||
(let ((rest (substr body (+ p1 1))))
|
||
(let ((p2 (index-of rest "|")))
|
||
(if (< p2 0) nil
|
||
{:src (substr body 0 p1)
|
||
:kind (substr rest 0 p2)
|
||
:dst (substr rest (+ p2 1))}))))))
|
||
nil)))
|
||
(define host/blog--all-edges
|
||
(fn ()
|
||
(filter (fn (e) (not (nil? e)))
|
||
(map host/blog--parse-edge-key (persist/backend-kv-keys host/blog-store)))))
|
||
|
||
;; outgoing targets / incoming sources of `slug` under `kind`, as existing slugs.
|
||
(define host/blog-out
|
||
(fn (slug kind)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :src) slug) (= (get e :kind) kind))
|
||
(concat acc (list (get e :dst))) acc))
|
||
(list) (host/blog--all-edges))))))
|
||
(define host/blog-in
|
||
(fn (slug kind)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :dst) slug) (= (get e :kind) kind))
|
||
(concat acc (list (get e :src))) acc))
|
||
(list) (host/blog--all-edges))))))
|
||
|
||
;; back-compat: "related posts" is just the symmetric "related" kind.
|
||
(define host/blog-related (fn (slug) (host/blog-out slug "related")))
|
||
|
||
;; ── typing: is-a + subtype-of with subsumption ──────────────────────
|
||
;; Typing is just relating to a type, and types ARE posts. A post DECLARES its
|
||
;; types with is-a edges; types form a hierarchy with subtype-of edges. is-a
|
||
;; (instance-of) is NOT transitive on its own, but subsumption is: an instance of
|
||
;; a subtype is an instance of the supertype. So a post's full type set is its
|
||
;; declared types PLUS every subtype-of-ancestor of each (relations/descendants
|
||
;; follows subtype-of transitively). Keeps the Datalog ruleset minimal — the
|
||
;; closure is composed host-side.
|
||
(define host/blog--uniq
|
||
(fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs)))
|
||
|
||
(define host/blog-types-of
|
||
(fn (slug)
|
||
(host/blog--uniq
|
||
(reduce
|
||
(fn (acc t)
|
||
(concat (concat acc (list t))
|
||
(host/blog--edge-slugs
|
||
(relations/descendants (host/blog--node t) (string->symbol "subtype-of")))))
|
||
(list)
|
||
(host/blog-out slug "is-a")))))
|
||
|
||
;; is this post (transitively) of the given type-slug?
|
||
(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type)))
|
||
|
||
;; all posts that are (transitively) instances of `type`: instances of the type
|
||
;; itself plus instances of any of its subtypes. Computed in O(#subtypes) relation
|
||
;; queries, NOT one type-resolution per post — the efficient way to enumerate a
|
||
;; type's members (e.g. "all tags") for the picker.
|
||
(define host/blog-instances-of
|
||
(fn (type)
|
||
(let ((subtypes
|
||
(concat (list type)
|
||
(host/blog--edge-slugs
|
||
(relations/ancestors (host/blog--node type) (string->symbol "subtype-of"))))))
|
||
(host/blog--uniq
|
||
(reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) (list) subtypes)))))
|
||
|
||
;; ── tags (a tag is a post that is-a tag) ────────────────────────────
|
||
(define host/blog-is-tag? (fn (slug) (host/blog-is-a? slug "tag")))
|
||
(define host/blog-tags (fn (slug) (host/blog-out slug "tagged"))) ;; a post's tags
|
||
(define host/blog-tagged-with (fn (tag) (host/blog-in tag "tagged"))) ;; posts with a tag
|
||
|
||
;; ── gradual validation: declarative type schemas ───────────────────
|
||
;; A type may carry a SCHEMA: a list of rules {:block <tag> :msg <why>}, each
|
||
;; requiring the content to contain (anywhere) an element of that tag. A post is
|
||
;; checked against the schema of every type it is-a; a type with no schema imposes
|
||
;; nothing (gradual). Schemas are declarative data (not opaque predicates) so they
|
||
;; yield a specific, human error — and could later be stored ON the type-post.
|
||
(define host/blog-type-schemas
|
||
{:article (list {:block "h1" :msg "an article needs a heading (h1)"})})
|
||
(define host/blog-schema-of (fn (type-slug) (get host/blog-type-schemas type-slug)))
|
||
|
||
;; every element tag in a parsed content tree, recursively (the heads of nested
|
||
;; lists) — so "requires h1" matches an h1 even inside an article/section wrapper.
|
||
(define host/blog--all-tags
|
||
(fn (tree)
|
||
(if (and (= (type-of tree) "list") (> (len tree) 0))
|
||
(concat (list (str (first tree)))
|
||
(reduce (fn (acc c) (concat acc (host/blog--all-tags c))) (list) (rest tree)))
|
||
(list))))
|
||
|
||
;; the :msg of each required :block a schema asks for but the content lacks.
|
||
(define host/blog--schema-issues
|
||
(fn (schema content)
|
||
(let ((tags (host/blog--all-tags (parse-safe content))))
|
||
(reduce
|
||
(fn (acc rule)
|
||
(if (contains? tags (get rule :block)) acc (concat acc (list (get rule :msg)))))
|
||
(list) schema))))
|
||
|
||
;; all schema issues for a post = the union over every type it is-a that carries a
|
||
;; schema. Empty = valid; vacuous (and cheap) when no type has a schema.
|
||
(define host/blog-type-issues
|
||
(fn (slug content)
|
||
(reduce
|
||
(fn (acc t)
|
||
(let ((s (host/blog-schema-of t)))
|
||
(if s (concat acc (host/blog--schema-issues s content)) acc)))
|
||
(list) (host/blog-types-of slug))))
|
||
(define host/blog-type-valid?
|
||
(fn (slug content) (= (len (host/blog-type-issues slug content)) 0)))
|
||
|
||
;; Seed the root type-posts: "type" (the root) and "tag" (a kind of type). Types
|
||
;; ARE posts, so these are real posts that document themselves; tag subtype-of
|
||
;; type means anything that is-a tag is, transitively, a type. Idempotent — safe
|
||
;; to call on every boot (host/blog-seed! no-ops if present, edges are sets).
|
||
(define host/blog-seed-types!
|
||
(fn ()
|
||
(begin
|
||
(host/blog-seed! "type" "Type"
|
||
"(article (h1 \"Type\") (p \"The root type. Types are posts — so this is a post that documents the idea of a type. A post declares its types with is-a edges; types form a hierarchy with subtype-of edges.\"))"
|
||
"published")
|
||
(host/blog-seed! "tag" "Tag"
|
||
"(article (h1 \"Tag\") (p \"A tag is a kind of type (tag subtype-of type), so anything that is-a tag is also a type. A post is tagged with a tag; a tag post documents the tag and lists what is tagged with it.\"))"
|
||
"published")
|
||
(host/blog-relate! "tag" "type" "subtype-of")
|
||
;; "article" — a type WITH a schema (requires a heading). Posts that is-a
|
||
;; article are validated against it on save (gradual typing in action).
|
||
(host/blog-seed! "article" "Article"
|
||
"(article (h1 \"Article\") (p \"A kind of post that must have a heading. A post that is-a article is checked against this type's schema on save — gradual typing: declaring the type adds the requirement, and the next edit must satisfy it.\"))"
|
||
"published")
|
||
(host/blog-relate! "article" "type" "subtype-of"))))
|
||
|
||
;; ── relate picker (filterable, paginated candidate list) ────────────
|
||
;; Candidates to relate `slug` to: every post except itself and ones already
|
||
;; related, narrowed by `q` (case-insensitive substring of title or slug),
|
||
;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`.
|
||
(define host/blog--picker-limit 20)
|
||
;; The candidate POOL for a kind comes from its registry :candidates: "all" posts,
|
||
;; or the members of a type ("tags" = instances of tag, "types" = instances of
|
||
;; type). Enumerating a type's members is O(#subtypes), not O(#posts).
|
||
(define host/blog--candidate-pool
|
||
(fn (candidates)
|
||
(cond
|
||
((= candidates "tags") (host/blog-instances-of "tag"))
|
||
((= candidates "types") (host/blog-instances-of "type"))
|
||
(else (host/blog-slugs)))))
|
||
|
||
(define host/blog--relate-candidates
|
||
(fn (slug q kind)
|
||
(let ((spec (host/blog--kind-spec kind)))
|
||
(let ((pool (host/blog--candidate-pool (get spec :candidates)))
|
||
(already (host/blog-out slug kind))
|
||
(ql (lower (or q ""))))
|
||
;; pool is slugs; resolve titles, drop self + already-linked, filter by q
|
||
(let ((cands
|
||
(filter
|
||
(fn (p)
|
||
(or (= ql "")
|
||
(contains? (lower (get p :title)) ql)
|
||
(contains? (get p :slug) ql)))
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (and (not (= s slug)) (not (contains? already s)))) pool)))))
|
||
;; title-sort via [title slug] pairs (sort compares the title first)
|
||
(map (fn (pair) {:slug (nth pair 1) :title (nth pair 0)})
|
||
(sort (map (fn (p) (list (get p :title) (get p :slug))) cands))))))))
|
||
|
||
;; One candidate row: a tiny form whose button adds the relation under `kind`.
|
||
(define host/blog--picker-item
|
||
(fn (slug p kind)
|
||
(quasiquote
|
||
(li :style "border-bottom:1px solid #eee"
|
||
;; sx-disable: this relate form is a plain POST -> 303 -> full reload (the
|
||
;; engine swaps the picker rows in, which would otherwise boost this form;
|
||
;; a boosted POST+redirect into #content swaps unreliably). A relate is a
|
||
;; deliberate action, so a clean reload that re-renders the editor is right.
|
||
(form :method "post" :style "margin:0" :sx-disable "true"
|
||
:action (unquote (str "/" slug "/relate"))
|
||
(input :type "hidden" :name "other" :value (unquote (get p :slug)))
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(button :type "submit"
|
||
:style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer"
|
||
(unquote (get p :title))))))))
|
||
|
||
;; The infinite-scroll "load more" sentinel: an <li> that, when scrolled into view
|
||
;; (sx-trigger "revealed"), GETs the NEXT page and replaces ITSELF (sx-swap
|
||
;; outerHTML, default self-target) with those rows + the next sentinel. This is the
|
||
;; SX-htmx engine doing the paging — no client JS. q is %-encoded back into the URL
|
||
;; so the filter is preserved across pages.
|
||
(define host/blog--picker-more
|
||
(fn (slug kind q next)
|
||
(quasiquote
|
||
(li :class "rp-more"
|
||
:style "list-style:none;padding:0.5em;text-align:center;opacity:0.6"
|
||
:sx-get (unquote (str "/" slug "/relate-options?kind=" kind
|
||
"&q=" (dr/url-encode q) "&offset=" next))
|
||
:sx-trigger "revealed"
|
||
:sx-swap "outerHTML"
|
||
;; a dropped/offline page-fetch retries with exponential backoff (1s→30s)
|
||
;; until it succeeds, so a flaky connection self-heals as you scroll.
|
||
:sx-retry "exponential:1000:30000"
|
||
"Loading more…"))))
|
||
|
||
;; GET /<slug>/relate-options?kind=&q=&offset= — one page of candidate rows for a
|
||
;; kind as an HTML fragment, swapped into the picker by the SX-htmx engine. A full
|
||
;; page is followed by a "load more" sentinel (above); the last page is not. Public
|
||
;; read; the relate action stays guarded.
|
||
(define host/blog-relate-options
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(kind (or (dream-query-param req "kind") "related"))
|
||
;; dream's query parser does not %-decode values (its form parser does),
|
||
;; so a filter like "Item 13" arrives as "Item%2013" — decode it.
|
||
(q (dr/url-decode (or (dream-query-param req "q") "")))
|
||
(offset (host/query-int req "offset" 0)))
|
||
(let ((page (take (drop (host/blog--relate-candidates slug q kind) offset)
|
||
host/blog--picker-limit)))
|
||
(let ((rows (join "" (map (fn (p) (render-page (host/blog--picker-item slug p kind))) page)))
|
||
(more (if (= (len page) host/blog--picker-limit)
|
||
(render-page (host/blog--picker-more slug kind q (+ offset host/blog--picker-limit)))
|
||
"")))
|
||
(dream-html (str rows more)))))))
|
||
|
||
|
||
;; ── page shell ──────────────────────────────────────────────────────
|
||
;; A page is an SX element tree, rendered via render-page (5.1). The handler
|
||
;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
|
||
;; loop) and render-page renders the static result — no embedded HTML strings,
|
||
;; only the doctype prefix render-to-html doesn't emit. `body` is an SX node.
|
||
;; SPA shell. The blog is a single-page app: the page boots the WASM OCaml kernel
|
||
;; (the SAME evaluator as the server) + the SX-htmx engine (web/engine.sx), and
|
||
;; `sx-boost="#content"` turns every in-page link/form into a fragment swap into
|
||
;; #content — no full reloads, history handled. A boosted request carries the
|
||
;; SX-Request:true header; we then return ONLY the inner content (so the engine
|
||
;; swaps it straight into #content). A direct / no-JS request gets the full shell,
|
||
;; so the blog degrades gracefully to plain server-rendered pages.
|
||
(define host/blog--spa-req? (fn (req) (= (dream-header req "sx-request") "true")))
|
||
|
||
(define host/blog--page
|
||
(fn (req title body)
|
||
(if (host/blog--spa-req? req)
|
||
;; SPA fragment: SX WIRE FORMAT (text/sx), not HTML. The WASM kernel parses
|
||
;; + renders it client-side into #content (the engine's handle-sx-response).
|
||
;; No server-side HTML render on the boosted path.
|
||
(serialize body)
|
||
;; full SPA shell: WASM kernel + platform + boosted #content (server HTML
|
||
;; for first load / no-JS / SEO)
|
||
(str "<!doctype html>"
|
||
(render-page
|
||
(quasiquote
|
||
(html
|
||
(head (meta :charset "utf-8") (title (unquote title))
|
||
;; content-addressed module manifest: {file -> hash}. The client's
|
||
;; loadBytecodeFile reads this and fetches each web-stack module
|
||
;; immutably from /sx/h/{hash} (localStorage-cached, never stale)
|
||
;; instead of /static/wasm/sx/*.sxbc with max-age.
|
||
(script :type "application/json" :data-sx-manifest "1"
|
||
(raw! (unquote (host/static-manifest-json))))
|
||
(script :src "/static/wasm/sx_browser.bc.wasm.js")
|
||
(script :src "/static/wasm/sx-platform.js")
|
||
;; Visible failure state for the SX engine's .sx-error class (added
|
||
;; on a failed/offline fetch, cleared on the next success). Without
|
||
;; it a stuck retry is invisible — the picker just sits "Loading…".
|
||
(style (raw! (unquote (str
|
||
".rp-more.sx-error{color:#b00}"
|
||
".rp-more.sx-error::after{content:\" — offline, retrying…\"}"
|
||
".relate-picker.sx-error .rp-results::before{"
|
||
"content:\"Connection problem — retrying…\";display:block;"
|
||
"padding:.5em;color:#b00;font-size:.9em}")))))
|
||
(body
|
||
;; sx-boost must be on a DESCENDANT of <body> (process-boosted
|
||
;; queries [sx-boost] WITHIN the body, so it can't sit on body
|
||
;; itself). The wrapper boosts every link/form inside, targeting
|
||
;; #content; #content is the swap target.
|
||
(div :sx-boost "#content"
|
||
(div :id "content" (unquote body)))))))))))
|
||
|
||
;; Wrap a host/blog--page result in a response with the matching content-type:
|
||
;; text/sx for a boosted (SPA) request (the WASM kernel renders it), text/html
|
||
;; for a full-page request. Replaces the old dream-html/-status wrappers so the
|
||
;; boosted path ships SX instead of server-rendered HTML.
|
||
(define host/blog--resp
|
||
(fn (req status str)
|
||
(dream-response status
|
||
{:content-type
|
||
(if (host/blog--spa-req? req) "text/sx; charset=utf-8" "text/html; charset=utf-8")}
|
||
str)))
|
||
|
||
;; ── registry-driven relation rendering (post page) ──────────────────
|
||
;; One labelled block of links from records ({:slug :title}), or "" when empty.
|
||
;; Records are pre-fetched, so the tree is built from in-memory data only.
|
||
(define host/blog--edges-block
|
||
(fn (records label)
|
||
(if (> (len records) 0)
|
||
(let ((items (map (fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
records)))
|
||
(quasiquote
|
||
(div :style "margin-top:2em"
|
||
(h3 (unquote label))
|
||
(unquote (cons (quote ul) items)))))
|
||
"")))
|
||
|
||
;; nodes -> {:slug :title} records, existence-filtered against a shared key set.
|
||
(define host/blog--recs
|
||
(fn (existing nodes)
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
|
||
|
||
;; The relation blocks shown on a POST page — a CURATED, fixed set: Related (out),
|
||
;; Tags (out), Tagged-with-this (in). PERFORMANCE: read the KV key list ONCE and
|
||
;; derive both the post set and the edges from it in memory, instead of letting
|
||
;; each host/blog-out/in re-scan the store. Every durable read is a perform routed
|
||
;; through cek_run_with_io (costly deep in the call stack), so the post page must
|
||
;; minimise them — this does ONE kv-keys plus a host/blog-get per linked post.
|
||
(define host/blog--post-relation-specs
|
||
(list {:kind "related" :dir "out" :label "Related posts"}
|
||
{:kind "tagged" :dir "out" :label "Tags"}
|
||
{:kind "tagged" :dir "in" :label "Tagged with this"}))
|
||
;; in-memory: the slug list (out: dst, in: src) for `slug` under `kind` from
|
||
;; pre-parsed edges — no perform.
|
||
(define host/blog--edges-for
|
||
(fn (edges slug kind dir)
|
||
(reduce
|
||
(fn (acc e)
|
||
(if (= (get e :kind) kind)
|
||
(if (= dir "out")
|
||
(if (= (get e :src) slug) (concat acc (list (get e :dst))) acc)
|
||
(if (= (get e :dst) slug) (concat acc (list (get e :src))) acc))
|
||
acc))
|
||
(list) edges)))
|
||
;; slug list -> {:slug :title} records (existence-filtered), one host/blog-get each.
|
||
(define host/blog--recs-slugs
|
||
(fn (existing slugs)
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (contains? existing s)) slugs))))
|
||
(define host/blog--relation-blocks
|
||
(fn (slug)
|
||
(let ((keys (persist/backend-kv-keys host/blog-store))) ;; ONE durable read
|
||
(let ((existing (reduce (fn (acc k)
|
||
(if (starts-with? k "blog:")
|
||
(concat acc (list (substr k 5))) acc))
|
||
(list) keys))
|
||
(edges (filter (fn (e) (not (nil? e)))
|
||
(map host/blog--parse-edge-key keys))))
|
||
(let ((blocks
|
||
(reduce
|
||
(fn (acc spec)
|
||
(let ((b (host/blog--edges-block
|
||
(host/blog--recs-slugs existing
|
||
(host/blog--edges-for edges slug (get spec :kind) (get spec :dir)))
|
||
(get spec :label))))
|
||
(if (= b "") acc (concat acc (list b)))))
|
||
(list)
|
||
host/blog--post-relation-specs)))
|
||
(if (> (len blocks) 0) (cons (quote div) blocks) ""))))))
|
||
|
||
;; the relation section for the post page: the blocks, or — when empty and the
|
||
;; viewer is logged in — a subtle "add some" hint; nothing for anonymous viewers.
|
||
(define host/blog--relations-or-hint
|
||
(fn (slug logged-in)
|
||
(let ((blocks (host/blog--relation-blocks slug)))
|
||
(cond
|
||
((not (= blocks "")) blocks)
|
||
(logged-in
|
||
(quasiquote
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
|
||
"No relations yet — "
|
||
(a :href (unquote (str "/" slug "/edit")) "add some") ".")))
|
||
(else "")))))
|
||
|
||
;; Kind-aware relation editor for the edit page: current links (each with a
|
||
;; kind-scoped remove), plus a filterable picker (a declarative SX-htmx form, one
|
||
;; per kind). The picker's candidates come from the kind's registry :candidates
|
||
;; ("all" / tags / types).
|
||
(define host/blog--relation-editor
|
||
(fn (slug kind)
|
||
;; current edges read up front (a perform) — NOT inside the quasiquote, where
|
||
;; a perform would raise VmSuspended under http-listen.
|
||
(let ((spec (host/blog--kind-spec kind))
|
||
(current (host/blog-out slug kind)))
|
||
(quasiquote
|
||
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(h3 (unquote (get spec :label)))
|
||
(unquote
|
||
(if (> (len current) 0)
|
||
(cons (quote ul)
|
||
(map (fn (s)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" s "/")) (unquote s)) " "
|
||
(form :method "post" :style "display:inline"
|
||
:action (unquote (str "/" slug "/unrelate"))
|
||
(input :type "hidden" :name "other" :value (unquote s))
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(button :type "submit" "remove")))))
|
||
current))
|
||
(quote (p :style "opacity:0.7" "None yet."))))
|
||
;; Declarative SX-htmx picker (no client JS). The form GETs relate-options
|
||
;; serialising its inputs (kind + the filter q) into the query: on initial
|
||
;; "load" and on a debounced "input" it innerHTML-swaps the results ul.
|
||
;; Paging is driven by the "load more" sentinel each page carries. The
|
||
;; SX engine re-binds these triggers on swapped-in content, so the picker
|
||
;; works whether the edit page is a full load or a boosted SPA nav.
|
||
(form :class "relate-picker" :data-slug (unquote slug) :data-kind (unquote kind)
|
||
:sx-get (unquote (str "/" slug "/relate-options"))
|
||
:sx-trigger "input delay:200ms, load"
|
||
:sx-target (unquote (str "#rp-" kind "-results"))
|
||
:sx-swap "innerHTML"
|
||
;; a failed initial/filter fetch retries with backoff (1s→30s)
|
||
:sx-retry "exponential:1000:30000"
|
||
:style "margin:0"
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(input :type "text" :name "q" :class "rp-filter" :placeholder "filter…" :autocomplete "off"
|
||
:style "width:100%;padding:0.4em;box-sizing:border-box")
|
||
(ul :id (unquote (str "rp-" kind "-results")) :class "rp-results"
|
||
:style "list-style:none;padding:0;margin:0.5em 0;border:1px solid #ddd")))))))
|
||
|
||
;; "Is this post a tag?" toggle — marking a post a tag is just an is-a edge to the
|
||
;; "tag" type-post, so it reuses the relate/unrelate routes (no new endpoint).
|
||
(define host/blog--is-tag-toggle
|
||
(fn (slug)
|
||
(if (host/blog-is-tag? slug)
|
||
(quasiquote
|
||
(p (span "This post is a tag ✓ ")
|
||
(form :method "post" :style "display:inline"
|
||
:action (unquote (str "/" slug "/unrelate"))
|
||
(input :type "hidden" :name "other" :value "tag")
|
||
(input :type "hidden" :name "kind" :value "is-a")
|
||
(button :type "submit" "remove tag status"))))
|
||
(quasiquote
|
||
(form :method "post" :action (unquote (str "/" slug "/relate"))
|
||
(input :type "hidden" :name "other" :value "tag")
|
||
(input :type "hidden" :name "kind" :value "is-a")
|
||
(button :type "submit" "Make this a tag"))))))
|
||
|
||
;; One editor per registry kind, wrapped in a div — the edit page's relation
|
||
;; section, generated by ITERATING the registry (add a kind -> it gets an editor).
|
||
(define host/blog--relation-editors
|
||
(fn (slug)
|
||
(cons (quote div)
|
||
(map (fn (spec) (host/blog--relation-editor slug (get spec :kind)))
|
||
host/blog-rel-kinds))))
|
||
|
||
;; ── read handlers ───────────────────────────────────────────────────
|
||
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
|
||
(define host/blog-post
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if r
|
||
;; Compute everything that does durable reads — body, related block, AND
|
||
;; the auth footer (a durable session read now) — in let bindings BEFORE
|
||
;; the quasiquote. IO must run in the handler body, never while the page
|
||
;; tree is built (a perform there raises VmSuspended under http-listen).
|
||
(let ((principal (host/current-principal req)))
|
||
(let ((body-html (host/blog-render r))
|
||
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
|
||
;; come from iterating the registry — one section, registry-driven.
|
||
(relations (host/blog--relations-or-hint slug (not (nil? principal))))
|
||
(auth-foot (host/auth-footer req)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req (get r :title)
|
||
(quasiquote
|
||
(div
|
||
(article (raw! (unquote body-html)))
|
||
(unquote relations)
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href (unquote (str "/" slug "/source")) "view source")
|
||
" · "
|
||
(a :href (unquote (str "/" slug "/edit")) "edit")
|
||
" · "
|
||
(a :href "/" "all posts")
|
||
" · "
|
||
(unquote auth-foot))))))))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote
|
||
(div (h1 "404")
|
||
(p (unquote (str "No published post: " slug))))))))))))
|
||
|
||
(define host/blog-home
|
||
(fn (req)
|
||
(let ((posts (host/blog-list)))
|
||
(let ((items
|
||
(map
|
||
(fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
posts)))
|
||
(let ((listing (if (> (len posts) 0)
|
||
(cons (quote ul) items)
|
||
(quote (p "No posts yet."))))
|
||
;; auth-footer does a durable session read — bind it BEFORE the
|
||
;; quasiquote (a perform during tree-build raises VmSuspended).
|
||
(auth-foot (host/auth-footer req)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "Blog"
|
||
(quasiquote
|
||
(div (h1 "Posts")
|
||
(unquote listing)
|
||
(p (a :href "/new" "+ New post"))
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(unquote auth-foot)))))))))))
|
||
|
||
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
|
||
|
||
;; GET /tags — index of every tag (a post that is-a tag). Tags are posts, so each
|
||
;; links to its own page (which documents the tag + lists what's tagged with it).
|
||
(define host/blog-tags-index
|
||
(fn (req)
|
||
;; pre-fetch records (slug+title) BEFORE the quasiquote — host/blog-get is a
|
||
;; durable read; a perform during tree-build raises VmSuspended.
|
||
(let ((recs (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(sort (host/blog-instances-of "tag"))))
|
||
(auth-foot (host/auth-footer req)))
|
||
(let ((items (map (fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
recs)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "Tags"
|
||
(quasiquote
|
||
(div (h1 "Tags")
|
||
(unquote (if (> (len recs) 0)
|
||
(cons (quote ul) items)
|
||
(quote (p "No tags yet."))))
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href "/" "all posts") " · " (unquote auth-foot))))))))))
|
||
|
||
;; GET /<slug>/source — the raw sx_content as text/plain. Posts ARE SX source, so
|
||
;; this just hands back the stored markup (public; a published post's source is
|
||
;; not secret). 404 if the post is absent.
|
||
(define host/blog-source
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if r
|
||
(dream-response 200 {:content-type "text/plain; charset=utf-8"}
|
||
(or (get r :sx-content) ""))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))))))))
|
||
|
||
;; ── create page (GET /new) — clean minimal form as an SX tree ───────
|
||
;; No legacy JS editor, no external assets, no shims. The rich WYSIWYG is a
|
||
;; future native SX-island editor (Phase 5.2+). Posts to /new.
|
||
(define host/blog-new-form
|
||
(fn (req)
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "New post"
|
||
(quasiquote
|
||
(div
|
||
(h1 "New post")
|
||
(form :method "post" :action "/new"
|
||
(p (input :name "title" :placeholder "Title"
|
||
:style "font-size:1.4em;width:100%"))
|
||
(p (textarea :name "sx_content" :rows "12"
|
||
:style "width:100%;font-family:monospace"
|
||
:placeholder "(p \"Your post as SX markup\")"))
|
||
(p (select :name "status"
|
||
(option :value "draft" "Draft")
|
||
(option :value "published" "Published"))
|
||
" "
|
||
(button :type "submit" "Publish")))
|
||
(p (a :href "/" "all posts"))))))))
|
||
|
||
;; ── write-time validation ───────────────────────────────────────────
|
||
;; sx_content must be storable as renderable SX: empty is allowed (an empty post),
|
||
;; otherwise it must parse. parse-safe returns nil on malformed input (the kernel
|
||
;; parser raises a native Parse_error an SX guard can't catch), so this rejects a
|
||
;; bad body at write time instead of letting it 500 on read. Mirrors the read-path
|
||
;; guard in host/blog-render — bad content never enters the durable store.
|
||
(define host/blog-content-ok?
|
||
(fn (sx)
|
||
(or (nil? sx) (= sx "") (not (nil? (parse-safe sx))))))
|
||
|
||
;; ── write handlers ──────────────────────────────────────────────────
|
||
;; POST /new — form-urlencoded ingest (the editor's submit shape: title,
|
||
;; sx_content, status, custom_excerpt, csrf_token). Slug derived from the title.
|
||
;; Redirects to the new post on success; rejects a missing title or unparseable
|
||
;; body with a 400 HTML page (this path serves a browser form).
|
||
(define host/blog-form-submit
|
||
(fn (req)
|
||
(let ((title (dream-form-field req "title"))
|
||
(sx-content (dream-form-field req "sx_content"))
|
||
(status (or (dream-form-field req "status") "published")))
|
||
(cond
|
||
((or (nil? title) (= title ""))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Error"
|
||
(quasiquote (div (h1 "Error") (p "Title is required.")
|
||
(p (a :href "/new" "Back")))))))
|
||
((not (host/blog-content-ok? sx-content))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Error"
|
||
(quasiquote (div (h1 "Error") (p "Post body is not valid SX markup.")
|
||
(p (a :href "/new" "Back")))))))
|
||
(else
|
||
(let ((slug (host/blog-slugify title)))
|
||
(begin
|
||
(host/blog-put! slug title (or sx-content "") status)
|
||
(dream-redirect (str "/" slug "/")))))))))
|
||
|
||
;; POST /posts — JSON create {slug?,title,sx_content,status}. 409 if slug exists.
|
||
(define host/blog-create
|
||
(fn (req)
|
||
(let ((p (dream-json-body req)))
|
||
(if (= (type-of p) "dict")
|
||
(let ((title (get p :title)))
|
||
(cond
|
||
((or (nil? title) (= title "")) (host/error 400 "title required"))
|
||
((not (host/blog-content-ok? (get p :sx_content)))
|
||
(host/error 400 "invalid sx_content"))
|
||
(else
|
||
(let ((slug (or (get p :slug) (host/blog-slugify title))))
|
||
(if (host/blog-exists? slug)
|
||
(host/error 409 "post already exists")
|
||
(begin
|
||
(host/blog-put! slug title (or (get p :sx_content) "")
|
||
(or (get p :status) "published"))
|
||
(host/ok-status 201 {:slug slug :title title})))))))
|
||
(host/error 400 "invalid payload")))))
|
||
|
||
;; PUT /posts/<slug> — JSON update {title?,sx_content?,status?}. 404 if absent.
|
||
(define host/blog-update-handler
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")) (p (dream-json-body req)))
|
||
(if (= (type-of p) "dict")
|
||
(let ((r (host/blog-get slug)))
|
||
(cond
|
||
((nil? r) (host/error 404 "no such post"))
|
||
((not (host/blog-content-ok? (get p :sx_content)))
|
||
(host/error 400 "invalid sx_content"))
|
||
(else
|
||
(begin
|
||
(host/blog-put! slug
|
||
(or (get p :title) (get r :title))
|
||
(or (get p :sx_content) (get r :sx-content))
|
||
(or (get p :status) (get r :status)))
|
||
(host/ok {:slug slug :updated true})))))
|
||
(host/error 400 "invalid payload")))))
|
||
|
||
;; DELETE /posts/<slug>
|
||
;; drop every edge touching `slug`, across all kinds + both directions, so a
|
||
;; deleted post leaves no dangling links anywhere in the graph.
|
||
(define host/blog--drop-all-edges!
|
||
(fn (slug)
|
||
(for-each
|
||
(fn (spec)
|
||
(let ((kind (get spec :kind)))
|
||
(begin
|
||
(for-each (fn (o) (host/blog-unrelate! slug o kind)) (host/blog-out slug kind))
|
||
(for-each (fn (o) (host/blog-unrelate! o slug kind)) (host/blog-in slug kind)))))
|
||
host/blog-rel-kinds)))
|
||
|
||
(define host/blog-delete-handler
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(if (host/blog-exists? slug)
|
||
(begin
|
||
(host/blog--drop-all-edges! slug)
|
||
(host/blog-delete! slug)
|
||
(host/ok {:slug slug :deleted true}))
|
||
(host/error 404 "no such post")))))
|
||
|
||
;; POST /<slug>/relate — relate this post to another (form `other` = slug, `kind` =
|
||
;; relation kind, default "related"). Validated: kind must be a known kind and the
|
||
;; other post must exist and differ; otherwise a no-op. Redirects back to the edit
|
||
;; page. Guarded like the other browser write routes.
|
||
(define host/blog-relate-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(other (dream-form-field req "other"))
|
||
(kind (or (dream-form-field req "kind") "related")))
|
||
(if (nil? (host/blog-get slug))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(begin
|
||
(when (and other (not (= other "")) (not (= other slug))
|
||
(host/blog--kind-spec kind) (host/blog-exists? other))
|
||
(host/blog-relate! slug other kind))
|
||
(dream-redirect (str "/" slug "/edit")))))))
|
||
|
||
;; POST /<slug>/unrelate — remove the relation to `other` under `kind` (default
|
||
;; "related"). Idempotent; redirects back to the edit page.
|
||
(define host/blog-unrelate-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(other (dream-form-field req "other"))
|
||
(kind (or (dream-form-field req "kind") "related")))
|
||
(begin
|
||
(when (and other (not (= other "")) (host/blog--kind-spec kind))
|
||
(host/blog-unrelate! slug other kind))
|
||
(dream-redirect (str "/" slug "/edit"))))))
|
||
|
||
;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw
|
||
;; sx_content (in a textarea — render-to-html escapes the text child, so the
|
||
;; browser shows the source verbatim), and status (current value pre-selected).
|
||
;; Guarded: only an editor reaches the editor. Keeps the slug (edits don't re-slug).
|
||
(define host/blog-edit-form
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if (nil? r)
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(let ((status (get r :status)))
|
||
;; the relation editors + tag toggle do durable reads — compute them
|
||
;; here, not in the quasiquote, so IO stays in the handler body.
|
||
(let ((relation-editors (host/blog--relation-editors slug))
|
||
(tag-toggle (host/blog--is-tag-toggle slug))
|
||
(mk-opt
|
||
(fn (val label)
|
||
(if (= val status)
|
||
(quasiquote (option :value (unquote val) :selected "selected" (unquote label)))
|
||
(quasiquote (option :value (unquote val) (unquote label)))))))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req (str "Edit: " (get r :title))
|
||
(quasiquote
|
||
(div
|
||
(h1 (unquote (str "Edit: " (get r :title))))
|
||
(form :method "post" :action (unquote (str "/" slug "/edit"))
|
||
(p (input :name "title" :value (unquote (get r :title))
|
||
:style "font-size:1.4em;width:100%"))
|
||
(p (textarea :name "sx_content" :rows "16"
|
||
:style "width:100%;font-family:monospace"
|
||
(unquote (or (get r :sx-content) ""))))
|
||
(p (select :name "status"
|
||
(unquote (mk-opt "draft" "Draft"))
|
||
(unquote (mk-opt "published" "Published")))
|
||
" "
|
||
(button :type "submit" "Save")))
|
||
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(unquote tag-toggle))
|
||
(unquote relation-editors)
|
||
(p :style "margin-top:1.5em"
|
||
(a :href (unquote (str "/" slug "/")) "view post")
|
||
" · "
|
||
(a :href (unquote (str "/" slug "/source")) "view source")))))))))))))
|
||
|
||
;; POST /<slug>/edit — save the edited source. Same write-time validation as the
|
||
;; create paths (unparseable body -> 400, post left intact). Slug is preserved.
|
||
(define host/blog-edit-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")) (r (host/blog-get (dream-param req "slug"))))
|
||
(if (nil? r)
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(let ((title (or (dream-form-field req "title") (get r :title)))
|
||
(sx-content (or (dream-form-field req "sx_content") ""))
|
||
(status (or (dream-form-field req "status") (get r :status))))
|
||
;; collect issues up front (perform): unparseable markup, then each
|
||
;; schema requirement the post's types impose. Empty = save.
|
||
(let ((issues (if (host/blog-content-ok? sx-content)
|
||
(host/blog-type-issues slug sx-content)
|
||
(list "Post body is not valid SX markup."))))
|
||
(if (= (len issues) 0)
|
||
(begin
|
||
(host/blog-put! slug title sx-content status)
|
||
(dream-redirect (str "/" slug "/")))
|
||
(let ((issue-items (map (fn (i) (quasiquote (li (unquote i)))) issues)))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Cannot save"
|
||
(quasiquote
|
||
(div (h1 "Cannot save")
|
||
(p "This post can't be saved yet:")
|
||
(unquote (cons (quote ul) issue-items))
|
||
(p (a :href (unquote (str "/" slug "/edit")) "Back"))))))))))))))
|
||
|
||
;; ── routes ──────────────────────────────────────────────────────────
|
||
;; Public reads + the create form. /, /posts, /new BEFORE /:slug (catch-all).
|
||
;; MUST be mounted LAST in the app so domain routes (/feed, /health) win.
|
||
(define host/blog-routes
|
||
(list
|
||
(dream-get "/" host/blog-home)
|
||
(dream-get "/posts" host/blog-index)
|
||
(dream-get "/new" host/blog-new-form)
|
||
(dream-get "/tags" host/blog-tags-index)
|
||
(dream-get "/:slug/source" host/blog-source)
|
||
(dream-get "/:slug/relate-options" host/blog-relate-options)
|
||
(dream-get "/:slug" host/blog-post)))
|
||
|
||
;; Guarded writes: form ingest + JSON create/update/delete behind auth+ACL.
|
||
;; NB: helper is host/blog--protect, NOT `guard` (reserved special form).
|
||
(define host/blog--protect
|
||
(fn (resolve h)
|
||
(host/pipeline
|
||
(list
|
||
host/wrap-errors
|
||
(host/require-user resolve)
|
||
(host/require-permission "edit" (fn (req) "blog")))
|
||
h)))
|
||
;; Browser variant: identical ACL gate, but an unauthenticated request REDIRECTS
|
||
;; to the login page (host/require-login) rather than returning a raw JSON 401 —
|
||
;; the form/edit pages are HTML, so a logged-out click should land on /login and
|
||
;; return here afterwards.
|
||
(define host/blog--protect-html
|
||
(fn (resolve h)
|
||
(host/pipeline
|
||
(list
|
||
host/wrap-errors
|
||
(host/require-login resolve)
|
||
(host/require-permission "edit" (fn (req) "blog")))
|
||
h)))
|
||
(define host/blog-write-routes
|
||
(fn (resolve)
|
||
(list
|
||
(dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit))
|
||
(dream-get "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-form))
|
||
(dream-post "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-submit))
|
||
(dream-post "/:slug/relate" (host/blog--protect-html resolve host/blog-relate-submit))
|
||
(dream-post "/:slug/unrelate" (host/blog--protect-html resolve host/blog-unrelate-submit))
|
||
(dream-post "/posts" (host/blog--protect resolve host/blog-create))
|
||
(dream-put "/posts/:slug" (host/blog--protect resolve host/blog-update-handler))
|
||
(dream-delete "/posts/:slug" (host/blog--protect resolve host/blog-delete-handler)))))
|
||
|
||
;; EXPERIMENTAL: create-only, UNGUARDED — POST /new form ingest with error
|
||
;; trapping but NO auth, for validating the editor->host publish loop on the
|
||
;; experimental subdomain. Create-only by design (no PUT/DELETE), so the worst
|
||
;; case is junk posts, not overwrite/delete. GATE before any real use.
|
||
(define host/blog-open-create-routes
|
||
(list
|
||
(dream-post "/new" (host/pipeline (list host/wrap-errors) host/blog-form-submit))))
|