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

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