rose-ash/lib/dream/form.sx

;; 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) ""))))

;; ── 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)))