giles
04aa537c7b
Make relating discoverable and pleasant: a hint on posts with no relations, and a real candidate picker on the edit page. - post page: when a post has no relations AND the viewer is logged in, show a subtle "No related posts yet — add some" hint linking to the edit page; anonymous viewers still see nothing. - GET /<slug>/relate-options?q=&offset= — SX endpoint returning one page of candidate rows (HTML <li> fragment): every post except itself and ones already related, narrowed by q (case-insensitive title/slug substring), title-sorted, paginated by host/blog--picker-limit. Public read; the relate POST stays guarded. - GET /relate-picker.js — small vanilla glue (debounced live filter + scroll-to-load-more) served from a route. The host serves static HTML (no SX island hydration), so the interactive layer is a cached script, not an island; data-slug on the input carries the post to it. - edit page: the plain "slug to relate" box becomes a filter input + scrollable results list (#relate-filter/#relate-results) populated by the script; each row is a one-click relate form. 8 tests: endpoint lists/excludes-self/filters-by-q/excludes-already-related, JS route content-type + glue, hint shown logged-in / hidden anonymous. 238/238. Verified live: hint (logged-in only), candidate rows, q=filter, JS route (node --check OK), edit picker UI with data-slug. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
578 lines
29 KiB
Plaintext
578 lines
29 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) ────────────────────────────────
|
||
;; A "related" link between two posts is a SYMMETRIC pair of edges in the
|
||
;; relations graph (lib/relations): node = "blog:<slug>", kind = related. Edges go
|
||
;; both ways so "related posts" reads the same from either side via children alone
|
||
;; — composing two already-migrated domains (blog + relations) on the host.
|
||
(define host/blog--rel-kind (string->symbol "related"))
|
||
(define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))
|
||
|
||
(define host/blog-relate!
|
||
(fn (a b)
|
||
(begin
|
||
(relations/relate (host/blog--node a) (host/blog--node b) host/blog--rel-kind)
|
||
(relations/relate (host/blog--node b) (host/blog--node a) host/blog--rel-kind))))
|
||
(define host/blog-unrelate!
|
||
(fn (a b)
|
||
(begin
|
||
(relations/unrelate (host/blog--node a) (host/blog--node b) host/blog--rel-kind)
|
||
(relations/unrelate (host/blog--node b) (host/blog--node a) host/blog--rel-kind))))
|
||
|
||
;; related slugs for a post: blog children under "related", stripped to slug, and
|
||
;; limited to posts that still exist (a deleted post can leave a dangling edge).
|
||
;; Existence is checked against ONE kv-keys read (host/blog-slugs), not a perform
|
||
;; per candidate — keeping IO out of the inner filter.
|
||
(define host/blog-related
|
||
(fn (slug)
|
||
(let ((existing (host/blog-slugs)))
|
||
(let ((kids (relations/children (host/blog--node slug) host/blog--rel-kind)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) kids)))))))
|
||
|
||
;; ── 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)
|
||
(define host/blog--relate-candidates
|
||
(fn (slug q)
|
||
(let ((already (host/blog-related slug))
|
||
(ql (lower (or q ""))))
|
||
(let ((cands
|
||
(filter
|
||
(fn (p)
|
||
(and (not (= (get p :slug) slug))
|
||
(not (contains? already (get p :slug)))
|
||
(or (= ql "")
|
||
(contains? (lower (get p :title)) ql)
|
||
(contains? (get p :slug) ql))))
|
||
(host/blog-list))))
|
||
;; 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 (POST /relate).
|
||
(define host/blog--picker-item
|
||
(fn (slug p)
|
||
(quasiquote
|
||
(li :style "border-bottom:1px solid #eee"
|
||
(form :method "post" :style "margin:0"
|
||
:action (unquote (str "/" slug "/relate"))
|
||
(input :type "hidden" :name "other" :value (unquote (get p :slug)))
|
||
(button :type "submit"
|
||
:style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer"
|
||
(unquote (get p :title))))))))
|
||
|
||
;; GET /<slug>/relate-options?q=&offset= — one page of candidate rows as an HTML
|
||
;; fragment (the <li>s the picker script appends). Public read (same data as
|
||
;; /posts); the relate action itself stays guarded.
|
||
(define host/blog-relate-options
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(q (or (dream-query-param req "q") ""))
|
||
(offset (host/query-int req "offset" 0)))
|
||
(let ((page (take (drop (host/blog--relate-candidates slug q) offset)
|
||
host/blog--picker-limit)))
|
||
(dream-html
|
||
(join "" (map (fn (p) (render-page (host/blog--picker-item slug p))) page)))))))
|
||
|
||
;; GET /relate-picker.js — progressive-enhancement glue for the edit-page picker:
|
||
;; debounced live filter + scroll-to-load-more against /<slug>/relate-options. The
|
||
;; host serves static HTML (no SX hydration), so the interactive layer is a small
|
||
;; vanilla script served from this route (read once, cached).
|
||
(define host/blog-picker-js-src
|
||
"(function(){var f=document.getElementById('relate-filter');if(!f)return;var r=document.getElementById('relate-results');var slug=f.getAttribute('data-slug'),off=0,q='',busy=false,done=false,t;function load(reset){if(busy||(!reset&&done))return;busy=true;if(reset){off=0;done=false;}fetch('/'+slug+'/relate-options?q='+encodeURIComponent(q)+'&offset='+off).then(function(x){return x.text();}).then(function(h){var d=document.createElement('div');d.innerHTML=h;var n=d.children.length;if(reset)r.innerHTML='';while(d.firstChild)r.appendChild(d.firstChild);off+=n;done=n<20;busy=false;}).catch(function(){busy=false;});}f.addEventListener('input',function(){clearTimeout(t);t=setTimeout(function(){q=f.value.trim();load(true);},200);});r.addEventListener('scroll',function(){if(r.scrollTop+r.clientHeight>=r.scrollHeight-40){load(false);}});load(true);})();")
|
||
(define host/blog-picker-js
|
||
(fn (req)
|
||
(dream-response 200 {:content-type "application/javascript; charset=utf-8"}
|
||
host/blog-picker-js-src)))
|
||
|
||
;; ── 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.
|
||
(define host/blog--page
|
||
(fn (title body)
|
||
(str "<!doctype html>"
|
||
(render-page
|
||
(quasiquote
|
||
(html
|
||
(head (meta :charset "utf-8") (title (unquote title)))
|
||
(body (unquote body))))))))
|
||
|
||
;; "Related posts" block for the post page: a list of links when there are any;
|
||
;; a subtle "add some" hint when there are none AND the viewer is logged in (an
|
||
;; editor); nothing for an anonymous viewer. Records (slug+title) are fetched up
|
||
;; front so the SX tree is built from in-memory data — no durable read happens
|
||
;; while the page tree is rendered.
|
||
(define host/blog--related-block
|
||
(fn (slug logged-in)
|
||
(let ((rel (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(host/blog-related slug))))
|
||
(cond
|
||
((> (len rel) 0)
|
||
(let ((items
|
||
(map (fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
rel)))
|
||
(quasiquote
|
||
(div :style "margin-top:2em"
|
||
(h3 "Related posts")
|
||
(unquote (list (quote ul) items))))))
|
||
(logged-in
|
||
(quasiquote
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
|
||
"No related posts yet — "
|
||
(a :href (unquote (str "/" slug "/edit")) "add some") ".")))
|
||
(else "")))))
|
||
|
||
;; Related-posts editor for the edit page: current links each with a remove
|
||
;; button, plus an "add related" box (relate by slug; the submit validates it).
|
||
(define host/blog--related-editor
|
||
(fn (slug)
|
||
(let ((rel (host/blog-related slug)))
|
||
(quasiquote
|
||
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(h3 "Related posts")
|
||
(unquote
|
||
(if (> (len rel) 0)
|
||
(list (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))
|
||
(button :type "submit" "remove")))))
|
||
rel))
|
||
(quote (p :style "opacity:0.7" "None yet."))))
|
||
;; add: a filterable, infinite-scrolling picker. The filter input + the
|
||
;; results list are populated by /relate-picker.js (debounced filter,
|
||
;; scroll-to-load) hitting /<slug>/relate-options; each row's button
|
||
;; POSTs /relate. data-slug carries the post to the script.
|
||
(h4 :style "margin-bottom:0.3em" "Add related")
|
||
(input :type "text" :id "relate-filter" :data-slug (unquote slug)
|
||
:placeholder "filter posts…" :autocomplete "off"
|
||
:style "width:100%;padding:0.4em;box-sizing:border-box")
|
||
(ul :id "relate-results"
|
||
:style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd")
|
||
(raw! "<script src=\"/relate-picker.js\"></script>"))))))
|
||
|
||
;; ── 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 the rendered body + related block in let bindings BEFORE the
|
||
;; quasiquote — host/blog--related-block does durable reads, and IO must
|
||
;; happen in the handler body, not while the page tree is being built.
|
||
(let ((body-html (host/blog-render r))
|
||
(related-block (host/blog--related-block slug
|
||
(not (nil? (host/current-principal req))))))
|
||
(dream-html
|
||
(host/blog--page (get r :title)
|
||
(quasiquote
|
||
(div
|
||
(article (raw! (unquote body-html)))
|
||
(unquote related-block)
|
||
(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 (host/auth-footer req))))))))
|
||
(dream-html-status 404
|
||
(host/blog--page "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)
|
||
(list (quote ul) items)
|
||
(quote (p "No posts yet.")))))
|
||
(dream-html
|
||
(host/blog--page "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 (host/auth-footer req))))))))))))
|
||
|
||
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
|
||
|
||
;; 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) ""))
|
||
(dream-html-status 404
|
||
(host/blog--page "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)
|
||
(dream-html
|
||
(host/blog--page "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 ""))
|
||
(dream-html-status 400
|
||
(host/blog--page "Error"
|
||
(quasiquote (div (h1 "Error") (p "Title is required.")
|
||
(p (a :href "/new" "Back")))))))
|
||
((not (host/blog-content-ok? sx-content))
|
||
(dream-html-status 400
|
||
(host/blog--page "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>
|
||
(define host/blog-delete-handler
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(if (host/blog-exists? slug)
|
||
(begin
|
||
;; drop the post's related edges so no dangling links survive it
|
||
(for-each (fn (o) (host/blog-unrelate! slug o)) (host/blog-related 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 field `other` = slug).
|
||
;; Validated: the other post must exist and differ; otherwise it's a no-op. Always
|
||
;; 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")))
|
||
(if (nil? (host/blog-get slug))
|
||
(dream-html-status 404
|
||
(host/blog--page "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(begin
|
||
(when (and other (not (= other "")) (not (= other slug)) (host/blog-exists? other))
|
||
(host/blog-relate! slug other))
|
||
(dream-redirect (str "/" slug "/edit")))))))
|
||
|
||
;; POST /<slug>/unrelate — remove the relation to `other`. 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")))
|
||
(begin
|
||
(when (and other (not (= other "")))
|
||
(host/blog-unrelate! slug other))
|
||
(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)
|
||
(dream-html-status 404
|
||
(host/blog--page "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(let ((status (get r :status)))
|
||
;; related-editor does durable reads — compute it here, not in the
|
||
;; quasiquote, so IO stays in the handler body.
|
||
(let ((related-editor (host/blog--related-editor 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)))))))
|
||
(dream-html
|
||
(host/blog--page (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")))
|
||
(unquote related-editor)
|
||
(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")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if (nil? r)
|
||
(dream-html-status 404
|
||
(host/blog--page "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))))
|
||
(if (host/blog-content-ok? sx-content)
|
||
(begin
|
||
(host/blog-put! slug title sx-content status)
|
||
(dream-redirect (str "/" slug "/")))
|
||
(dream-html-status 400
|
||
(host/blog--page "Error"
|
||
(quasiquote (div (h1 "Error") (p "Post body is not valid SX markup.")
|
||
(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 "/relate-picker.js" host/blog-picker-js)
|
||
(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))))
|