diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 872eeec3..7138cfdc 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -159,22 +159,42 @@ (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. +;; 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"))) - (if (and title (not (= title ""))) - (let ((slug (host/blog-slugify title))) - (begin - (host/blog-put! slug title (or sx-content "") status) - (dream-redirect (str "/" slug "/")))) - (dream-html-status 400 - (host/blog--page "Error" "
Title is required. back
")))))) + (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 @@ -182,15 +202,18 @@ (let ((p (dream-json-body req))) (if (= (type-of p) "dict") (let ((title (get p :title))) - (if (and title (not (= title ""))) - (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 "title required"))) + (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/