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/ — JSON update {title?,sx_content?,status?}. 404 if absent. @@ -199,14 +222,17 @@ (let ((slug (dream-param req "slug")) (p (dream-json-body req))) (if (= (type-of p) "dict") (let ((r (host/blog-get slug))) - (if r - (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 404 "no such post"))) + (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/ diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index bf36e9e1..692355ee 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -124,6 +124,31 @@ (dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/ghost" "Bearer good" "" ""))) 404) +;; -- write-time validation: malformed sx_content rejected, never stored -- +;; "%3Ch1+broken%29" decodes to "

400" + (dream-status (host-bl-wapp (host-bl-send "POST" "/new" "Bearer good" + "application/x-www-form-urlencoded" + "title=Bad+Form&sx_content=%3Ch1+broken%29&status=published"))) + 400) +(host-bl-test "rejected form post was not stored" + (dream-status (host-bl-wapp (host-bl-req "/bad-form/"))) + 404) +(host-bl-test "json create malformed sx_content -> 400" + (dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json" + "{\"title\":\"Bad Json\",\"sx_content\":\"

400" + (dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/my-first-post" "Bearer good" + "application/json" "{\"sx_content\":\"

My First Post

") + true) + ;; -- experimental unguarded create-only route (POST /new, no auth) -- (define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes))) (host/blog-use-store! (persist/open))