giles
bdc7e02fbc
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Three composing pieces that make the blog SPA correct and resilient.
Content-addressed module cache (lib/host/static.sx, serve.sh, blog.sx shell,
conformance.sh): index each web-stack .sxbc by the content hash in its head,
serve GET /sx/h/{hash} immutable text/sx, and emit <script data-sx-manifest>
{file->hash} so the WASM client loads modules content-addressed (localStorage +
immutable) instead of path + max-age. serve.sh builds the index at boot;
conformance.sh now loads static.sx before blog.sx (the shell calls
host/static-manifest-json).
Declarative relate picker (lib/host/blog.sx, lib/dream/form.sx): replace the
inline /relate-picker.js blob — which never ran on swapped-in content, so the
candidate list was empty after a boosted nav to /<slug>/edit — with a declarative
SX-htmx form: sx-get relate-options on "load" + debounced "input", innerHTML-swap
the results ul; infinite scroll via a server-emitted "load more" sentinel
(sx-trigger revealed, sx-swap outerHTML) that pages the rest, q preserved via a
new symmetric dr/url-encode. The engine re-binds these triggers on swapped
content, so the picker populates on full load AND boosted SPA nav. Candidate
relate forms get :sx-disable (plain POST->303->reload, their original behavior;
the engine would otherwise boost them and swap the redirect unreliably).
sx-retry "exponential:1000:30000" on the form+sentinel retries a dropped/offline
fetch forever (the cap bounds the interval, not the attempts).
SIGPIPE hardening (hosts/ocaml/bin/sx_server.ml): the native http-listen server
had no SIGPIPE handler, so a client aborting an in-flight fetch (the engine
cancels superseded requests on a debounced filter/fast nav) closed the socket
mid-write and killed the whole process (exit 141). Ignore SIGPIPE so the failed
write becomes a catchable Sys_error the per-connection handler already swallows.
Tests: host conformance 272/272; relate-picker.spec.js 5/5 incl. a boosted-nav
populate regression; spa-check 4/4.
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
404 lines
10 KiB
Plaintext
404 lines
10 KiB
Plaintext
;; lib/dream/form.sx — Dream-on-SX forms + CSRF.
|
|
;; Parses application/x-www-form-urlencoded bodies; CSRF tokens are stateless,
|
|
;; signed, and session-scoped. The signing function is injectable (a pure-SX keyed
|
|
;; hash by default — production should swap in a host HMAC). Depends on types.sx +
|
|
;; session.sx. dream-form returns an Ok/Err result value.
|
|
|
|
;; ── Result (Ok/Err) ────────────────────────────────────────────────
|
|
(define dream-ok (fn (v) {:value v :result "ok"}))
|
|
(define dream-err (fn (r) {:reason r :result "err"}))
|
|
(define dream-ok? (fn (x) (= (get x :result) "ok")))
|
|
(define dream-err? (fn (x) (= (get x :result) "err")))
|
|
(define dream-ok-value (fn (x) (get x :value)))
|
|
(define dream-err-reason (fn (x) (get x :reason)))
|
|
|
|
;; ── percent decoding ───────────────────────────────────────────────
|
|
(define
|
|
dr/hex-digit
|
|
(fn
|
|
(c)
|
|
(let
|
|
((n (char-code c)))
|
|
(cond
|
|
((and (>= n 48) (<= n 57)) (- n 48))
|
|
((and (>= n 65) (<= n 70))
|
|
(+ 10 (- n 65)))
|
|
((and (>= n 97) (<= n 102))
|
|
(+ 10 (- n 97)))
|
|
(else 0)))))
|
|
|
|
(define
|
|
dr/url-decode-loop
|
|
(fn
|
|
(s i n acc)
|
|
(if
|
|
(>= i n)
|
|
acc
|
|
(let
|
|
((c (char-at s i)))
|
|
(if
|
|
(and (= c "%") (< (+ i 2) n))
|
|
(dr/url-decode-loop
|
|
s
|
|
(+ i 3)
|
|
n
|
|
(str
|
|
acc
|
|
(char-from-code
|
|
(+
|
|
(* 16 (dr/hex-digit (char-at s (+ i 1))))
|
|
(dr/hex-digit (char-at s (+ i 2)))))))
|
|
(dr/url-decode-loop s (+ i 1) n (str acc c)))))))
|
|
|
|
(define
|
|
dr/url-decode
|
|
(fn
|
|
(s)
|
|
(let
|
|
((s2 (replace s "+" " ")))
|
|
(dr/url-decode-loop s2 0 (string-length s2) ""))))
|
|
|
|
;; ── percent encoding (symmetric with dr/url-decode) ────────────────
|
|
;; RFC3986 unreserved set passes through; everything else is %XX (uppercase
|
|
;; hex). Space becomes %20 (not +), so the result is safe in a query value.
|
|
(define dr/hex-chars "0123456789ABCDEF")
|
|
(define
|
|
dr/url-encode-char
|
|
(fn
|
|
(c)
|
|
(let
|
|
((n (char-code c)))
|
|
(if
|
|
(or
|
|
(and (>= n 48) (<= n 57)) ;; 0-9
|
|
(and (>= n 65) (<= n 90)) ;; A-Z
|
|
(and (>= n 97) (<= n 122)) ;; a-z
|
|
(= c "-") (= c "_") (= c ".") (= c "~"))
|
|
c
|
|
(str "%"
|
|
(char-at dr/hex-chars (quotient n 16))
|
|
(char-at dr/hex-chars (mod n 16)))))))
|
|
|
|
(define
|
|
dr/url-encode-loop
|
|
(fn
|
|
(s i n acc)
|
|
(if
|
|
(>= i n)
|
|
acc
|
|
(dr/url-encode-loop s (+ i 1) n
|
|
(str acc (dr/url-encode-char (char-at s i)))))))
|
|
|
|
(define
|
|
dr/url-encode
|
|
(fn
|
|
(s)
|
|
(dr/url-encode-loop (or s "") 0 (string-length (or s "")) "")))
|
|
|
|
;; ── substring splitter (split primitive is char-class based) ───────
|
|
(define
|
|
dr/split-on
|
|
(fn
|
|
(s sep)
|
|
(let
|
|
((i (index-of s sep)))
|
|
(if
|
|
(< i 0)
|
|
(list s)
|
|
(cons
|
|
(substr s 0 i)
|
|
(dr/split-on (substr s (+ i (string-length sep))) sep))))))
|
|
|
|
;; ── urlencoded body parsing ────────────────────────────────────────
|
|
(define
|
|
dr/parse-form-body
|
|
(fn
|
|
(body)
|
|
(if
|
|
(= body "")
|
|
{}
|
|
(reduce
|
|
(fn
|
|
(acc pair)
|
|
(if
|
|
(= pair "")
|
|
acc
|
|
(let
|
|
((j (index-of pair "=")))
|
|
(if
|
|
(< j 0)
|
|
(assoc acc (dr/url-decode pair) "")
|
|
(assoc
|
|
acc
|
|
(dr/url-decode (substr pair 0 j))
|
|
(dr/url-decode (substr pair (+ j 1))))))))
|
|
{}
|
|
(split body "&")))))
|
|
|
|
;; raw fields, no CSRF check
|
|
(define dream-form-fields (fn (req) (dr/parse-form-body (dream-body req))))
|
|
(define
|
|
dream-form-field
|
|
(fn (req name) (get (dream-form-fields req) name)))
|
|
|
|
;; ── CSRF signing (injectable; pure-SX keyed hash default) ──────────
|
|
(define
|
|
dr/poly-hash
|
|
(fn (s base seed) (dr/poly-loop s 0 (string-length s) seed base)))
|
|
(define
|
|
dr/poly-loop
|
|
(fn
|
|
(s i n h base)
|
|
(if
|
|
(>= i n)
|
|
h
|
|
(dr/poly-loop
|
|
s
|
|
(+ i 1)
|
|
n
|
|
(mod (+ (* h base) (char-code (char-at s i))) 2147483647)
|
|
base))))
|
|
|
|
;; NOTE: not cryptographic — adequate to demonstrate stateless CSRF; production
|
|
;; should inject a real HMAC via dream-csrf-with.
|
|
(define
|
|
dream-csrf-sign-default
|
|
(fn
|
|
(secret msg)
|
|
(let
|
|
((m (str secret "|" msg)))
|
|
(str
|
|
(dr/poly-hash m 131 7)
|
|
"-"
|
|
(dr/poly-hash m 137 13)))))
|
|
|
|
(define dream-csrf-field-name "dream.csrf")
|
|
|
|
(define
|
|
dr/csrf-make-token
|
|
(fn (sign secret sid) (str sid "." (sign secret sid))))
|
|
|
|
(define
|
|
dr/csrf-valid?
|
|
(fn
|
|
(sign secret sid token)
|
|
(if
|
|
(or (nil? token) (= token ""))
|
|
false
|
|
(let
|
|
((dot (index-of token ".")))
|
|
(if
|
|
(< dot 0)
|
|
false
|
|
(let
|
|
((tsid (substr token 0 dot))
|
|
(tsig (substr token (+ dot 1))))
|
|
(and (= tsid sid) (= tsig (sign secret sid)))))))))
|
|
|
|
;; ── CSRF middleware: attach signing context (needs session upstream) ──
|
|
(define
|
|
dream-csrf-with
|
|
(fn
|
|
(secret sign)
|
|
(fn (next) (fn (req) (next (assoc req :dream-csrf {:sign sign :sid (dream-session-id req) :secret secret}))))))
|
|
|
|
(define
|
|
dream-csrf
|
|
(fn (secret) (dream-csrf-with secret dream-csrf-sign-default)))
|
|
|
|
(define dr/csrf-of (fn (req) (get req :dream-csrf)))
|
|
|
|
;; current token + hidden-input tag for templates
|
|
(define
|
|
dream-csrf-token
|
|
(fn
|
|
(req)
|
|
(let
|
|
((c (dr/csrf-of req)))
|
|
(dr/csrf-make-token (get c :sign) (get c :secret) (get c :sid)))))
|
|
|
|
(define
|
|
dream-csrf-tag
|
|
(fn
|
|
(req)
|
|
(str
|
|
"<input type=\"hidden\" name=\""
|
|
dream-csrf-field-name
|
|
"\" value=\""
|
|
(dream-csrf-token req)
|
|
"\">")))
|
|
|
|
;; ── dream-form: parse + verify CSRF -> Ok fields | Err reason ──────
|
|
(define
|
|
dream-form
|
|
(fn
|
|
(req)
|
|
(let
|
|
((c (dr/csrf-of req)))
|
|
(if
|
|
(nil? c)
|
|
(dream-err :csrf-context-missing)
|
|
(let
|
|
((fields (dream-form-fields req)))
|
|
(if
|
|
(dr/csrf-valid?
|
|
(get c :sign)
|
|
(get c :secret)
|
|
(get c :sid)
|
|
(get fields dream-csrf-field-name))
|
|
(dream-ok fields)
|
|
(dream-err :csrf-token-invalid)))))))
|
|
|
|
;; ── CSRF auto-rejecting middleware (unsafe methods need a valid token) ──
|
|
(define
|
|
dr/csrf-safe-method?
|
|
(fn (m) (or (= m "GET") (= m "HEAD") (= m "OPTIONS"))))
|
|
|
|
(define
|
|
dream-csrf-protect-with
|
|
(fn
|
|
(secret sign)
|
|
(fn
|
|
(next)
|
|
(fn
|
|
(req)
|
|
(let
|
|
((req2 (assoc req :dream-csrf {:sign sign :sid (dream-session-id req) :secret secret})))
|
|
(if
|
|
(dr/csrf-safe-method? (dream-method req2))
|
|
(next req2)
|
|
(let
|
|
((token (get (dream-form-fields req2) dream-csrf-field-name)))
|
|
(if
|
|
(dr/csrf-valid? sign secret (dream-session-id req2) token)
|
|
(next req2)
|
|
(dream-html-status 403 "CSRF token invalid")))))))))
|
|
|
|
(define
|
|
dream-csrf-protect
|
|
(fn (secret) (dream-csrf-protect-with secret dream-csrf-sign-default)))
|
|
|
|
;; ── multipart/form-data parsing ────────────────────────────────────
|
|
;; In-memory (not yet streaming): parses the whole body into parts, each
|
|
;; {:name :filename :content-type :content}. Returns Ok parts | Err :not-multipart.
|
|
(define
|
|
dr/multipart-boundary
|
|
(fn
|
|
(ctype)
|
|
(let
|
|
((i (index-of ctype "boundary=")))
|
|
(if
|
|
(< i 0)
|
|
""
|
|
(let
|
|
((raw (trim (substr ctype (+ i 9)))))
|
|
(if
|
|
(starts-with? raw "\"")
|
|
(substr raw 1 (- (string-length raw) 2))
|
|
raw))))))
|
|
|
|
;; strip one leading and one trailing CRLF
|
|
(define
|
|
dr/strip-edges
|
|
(fn
|
|
(s)
|
|
(let
|
|
((s1 (if (starts-with? s "\r\n") (substr s 2) s)))
|
|
(if
|
|
(ends-with? s1 "\r\n")
|
|
(substr s1 0 (- (string-length s1) 2))
|
|
s1))))
|
|
|
|
;; value of attr="..." within a header block
|
|
(define
|
|
dr/cd-attr
|
|
(fn
|
|
(block attr)
|
|
(let
|
|
((key (str attr "=\"")))
|
|
(let
|
|
((i (index-of block key)))
|
|
(if
|
|
(< i 0)
|
|
nil
|
|
(let
|
|
((rest (substr block (+ i (string-length key)))))
|
|
(substr rest 0 (index-of rest "\""))))))))
|
|
|
|
;; value of a named header line within a header block
|
|
(define
|
|
dr/block-header
|
|
(fn
|
|
(block name)
|
|
(reduce
|
|
(fn
|
|
(acc line)
|
|
(if
|
|
(and
|
|
(nil? acc)
|
|
(starts-with? (lower line) (str (lower name) ":")))
|
|
(trim (substr line (+ (index-of line ":") 1)))
|
|
acc))
|
|
nil
|
|
(dr/split-on block "\r\n"))))
|
|
|
|
(define
|
|
dr/parse-part
|
|
(fn
|
|
(seg)
|
|
(let
|
|
((s (dr/strip-edges seg)))
|
|
(let
|
|
((sp (index-of s "\r\n\r\n")))
|
|
(if
|
|
(< sp 0)
|
|
nil
|
|
(let
|
|
((block (substr s 0 sp))
|
|
(content (substr s (+ sp 4))))
|
|
{:name (dr/cd-attr block "name") :filename (dr/cd-attr block "filename") :content-type (dr/block-header block "content-type") :content content}))))))
|
|
|
|
(define
|
|
dream-multipart
|
|
(fn
|
|
(req)
|
|
(let
|
|
((boundary (dr/multipart-boundary (or (dream-header req "content-type") ""))))
|
|
(if
|
|
(= boundary "")
|
|
(dream-err :not-multipart)
|
|
(let
|
|
((segs (dr/split-on (dream-body req) (str "--" boundary))))
|
|
(dream-ok
|
|
(filter
|
|
(fn (p) (not (nil? p)))
|
|
(map
|
|
dr/parse-part
|
|
(filter (fn (seg) (starts-with? seg "\r\n")) segs)))))))))
|
|
|
|
;; accessors over a parts list
|
|
(define
|
|
dream-multipart-field
|
|
(fn
|
|
(parts name)
|
|
(reduce
|
|
(fn
|
|
(acc p)
|
|
(if (and (nil? acc) (= (get p :name) name)) (get p :content) acc))
|
|
nil
|
|
parts)))
|
|
|
|
(define
|
|
dream-multipart-file
|
|
(fn
|
|
(parts name)
|
|
(reduce
|
|
(fn
|
|
(acc p)
|
|
(if
|
|
(and (nil? acc) (= (get p :name) name) (get p :filename))
|
|
p
|
|
acc))
|
|
nil
|
|
parts)))
|