rose-ash/lib/dream/session.sx

;; lib/dream/session.sx — Dream-on-SX cookie-backed sessions.
;; The session cookie carries only a session id; fields live in a back-end store.
;; The store is injectable: production wires it to (perform op); tests pass an
;; in-memory store. Depends on types.sx. Also hosts shared cookie helpers reused
;; by flash.sx and form.sx.

;; ── cookie helpers (shared) ────────────────────────────────────────
(define
  dr/parse-cookies
  (fn
    (header)
    (if
      (or (nil? header) (= header ""))
      {}
      (reduce
        (fn
          (acc part)
          (let
            ((kv (trim part)))
            (let
              ((j (index-of kv "=")))
              (if
                (< j 0)
                acc
                (assoc
                  acc
                  (substr kv 0 j)
                  (substr kv (+ j 1)))))))
        {}
        (split header ";")))))

(define
  dream-cookie
  (fn (req name) (get (dr/parse-cookies (dream-header req "cookie")) name)))
(define
  dream-cookies
  (fn (req) (dr/parse-cookies (dream-header req "cookie"))))

(define
  dr/build-cookie
  (fn
    (name val opts)
    (let
      ((o (if (nil? opts) {} opts)))
      (str
        name
        "="
        val
        "; Path="
        (or (get o :path) "/")
        (if (get o :http-only) "; HttpOnly" "")
        (if (get o :secure) "; Secure" "")
        (if (get o :same-site) (str "; SameSite=" (get o :same-site)) "")
        (if (get o :max-age) (str "; Max-Age=" (get o :max-age)) "")))))

(define
  dream-set-cookie
  (fn
    (resp name val opts)
    (assoc
      resp
      :set-cookies (concat
        (or (get resp :set-cookies) (list))
        (list (dr/build-cookie name val opts))))))

(define
  dream-resp-cookies
  (fn (resp) (or (get resp :set-cookies) (list))))

;; expire a cookie on the client
(define
  dream-drop-cookie
  (fn (resp name) (dream-set-cookie resp name "" {:max-age 0})))

;; ── signed cookie values (tamper-evident) ──────────────────────────
;; NOTE: pure-SX keyed hash — not cryptographic; production should inject a host
;; HMAC. Value carries no "." so the first "." splits value from signature.
(define
  dr/sess-hash
  (fn (s) (dr/sess-hash-loop s 0 (string-length s) 7)))
(define
  dr/sess-hash-loop
  (fn
    (s i n h)
    (if
      (>= i n)
      h
      (dr/sess-hash-loop
        s
        (+ i 1)
        n
        (mod (+ (* h 131) (char-code (char-at s i))) 2147483647)))))
(define
  dr/sess-sig
  (fn (secret val) (str (dr/sess-hash (str secret "|" val)))))

(define
  dream-cookie-sign
  (fn (secret val) (str val "." (dr/sess-sig secret val))))
(define
  dream-cookie-unsign
  (fn
    (secret signed)
    (if
      (or (nil? signed) (= signed ""))
      nil
      (let
        ((dot (index-of signed ".")))
        (if
          (< dot 0)
          nil
          (let
            ((val (substr signed 0 dot))
              (sig (substr signed (+ dot 1))))
            (if (= sig (dr/sess-sig secret val)) val nil)))))))

;; ── in-memory session store (tests + demos) ────────────────────────
;; A backend is (fn (op) result) where op is a dict {:op ... :sid ... :key ...}.
(define
  dream-memory-sessions
  (fn
    ()
    (let
      ((store {}) (counter 0))
      (fn
        (op)
        (let
          ((kind (get op :op)))
          (cond
            ((= kind "session/create")
              (begin
                (set! counter (+ counter 1))
                (let
                  ((sid (str "s" counter)))
                  (begin (set! store (assoc store sid {})) sid))))
            ((= kind "session/exists") (has-key? store (get op :sid)))
            ((= kind "session/get")
              (get (or (get store (get op :sid)) {}) (get op :key)))
            ((= kind "session/set")
              (let
                ((sid (get op :sid)))
                (set!
                  store
                  (assoc
                    store
                    sid
                    (assoc
                      (or (get store sid) {})
                      (get op :key)
                      (get op :val))))))
            ((= kind "session/load")
              (or (get store (get op :sid)) {}))
            ((= kind "session/clear")
              (set! store (dissoc store (get op :sid))))
            (else nil)))))))

;; production back-end: every op suspends to the host
(define dream-perform-sessions (fn (op) (perform op)))

;; ── session middleware ─────────────────────────────────────────────
(define dream-session-cookie-name "dream.session")

(define
  dream-sessions
  (fn
    (backend)
    (fn
      (next)
      (fn
        (req)
        (let
          ((sid0 (dream-cookie req dream-session-cookie-name)))
          (let
            ((have (and sid0 (backend {:op "session/exists" :sid sid0}))))
            (let
              ((sid (if have sid0 (backend {:op "session/create"}))))
              (let
                ((resp (next (assoc req :dream-session {:io backend :sid sid}))))
                (if
                  have
                  resp
                  (dream-set-cookie
                    resp
                    dream-session-cookie-name
                    sid
                    {:path "/" :http-only true :same-site "Lax"}))))))))))

;; signed variant: the cookie value is signed so a guessed/forged sid is rejected
(define
  dream-sessions-signed
  (fn
    (backend secret)
    (fn
      (next)
      (fn
        (req)
        (let
          ((sid0 (dream-cookie-unsign secret (dream-cookie req dream-session-cookie-name))))
          (let
            ((have (and sid0 (backend {:op "session/exists" :sid sid0}))))
            (let
              ((sid (if have sid0 (backend {:op "session/create"}))))
              (let
                ((resp (next (assoc req :dream-session {:io backend :sid sid}))))
                (if
                  have
                  resp
                  (dream-set-cookie
                    resp
                    dream-session-cookie-name
                    (dream-cookie-sign secret sid)
                    {:path "/" :http-only true :same-site "Lax"}))))))))))

;; ── handler-facing session API ─────────────────────────────────────
(define dr/session-of (fn (req) (get req :dream-session)))
(define dream-session-id (fn (req) (get (dr/session-of req) :sid)))

(define
  dream-session-field
  (fn
    (req key)
    (let ((s (dr/session-of req))) ((get s :io) {:key key :op "session/get" :sid (get s :sid)}))))

(define
  dream-set-session-field
  (fn
    (req key val)
    (let ((s (dr/session-of req))) (begin ((get s :io) {:val val :key key :op "session/set" :sid (get s :sid)}) req))))

(define
  dream-session-all
  (fn (req) (let ((s (dr/session-of req))) ((get s :io) {:op "session/load" :sid (get s :sid)}))))

(define
  dream-invalidate-session
  (fn
    (req)
    (let ((s (dr/session-of req))) (begin ((get s :io) {:op "session/clear" :sid (get s :sid)}) req))))