rose-ash/lib/dream/auth.sx

;; lib/dream/auth.sx — Dream-on-SX authentication helpers.
;; HTTP Basic auth (with a pure-SX base64 codec) and Bearer-token guards.
;; Depends on types.sx.

;; ── base64 (pure SX; arithmetic, no bitwise) ───────────────────────
(define
  dr/b64-alpha
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(define dr/b64-char (fn (n) (char-at dr/b64-alpha n)))
(define dr/b64-index (fn (c) (index-of dr/b64-alpha c)))

(define
  dr/b64-encode-loop
  (fn
    (s i n acc)
    (if
      (>= i n)
      acc
      (let
        ((b0 (char-code (char-at s i))) (rem (- n i)))
        (cond
          ((>= rem 3)
            (let
              ((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256) (char-code (char-at s (+ i 2))))))
              (dr/b64-encode-loop
                s
                (+ i 3)
                n
                (str
                  acc
                  (dr/b64-char (mod (quotient triple 262144) 64))
                  (dr/b64-char (mod (quotient triple 4096) 64))
                  (dr/b64-char (mod (quotient triple 64) 64))
                  (dr/b64-char (mod triple 64))))))
          ((= rem 2)
            (let
              ((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256))))
              (str
                acc
                (dr/b64-char (mod (quotient triple 262144) 64))
                (dr/b64-char (mod (quotient triple 4096) 64))
                (dr/b64-char (mod (quotient triple 64) 64))
                "=")))
          (else
            (let
              ((triple (* b0 65536)))
              (str
                acc
                (dr/b64-char (mod (quotient triple 262144) 64))
                (dr/b64-char (mod (quotient triple 4096) 64))
                "=="))))))))

(define
  dream-base64-encode
  (fn (s) (dr/b64-encode-loop s 0 (string-length s) "")))

(define
  dr/b64-decode-loop
  (fn
    (s i n acc)
    (if
      (>= i n)
      acc
      (let
        ((p2 (char-at s (+ i 2)))
          (p3 (char-at s (+ i 3))))
        (let
          ((c0 (dr/b64-index (char-at s i)))
            (c1 (dr/b64-index (char-at s (+ i 1))))
            (c2 (if (= p2 "=") 0 (dr/b64-index p2)))
            (c3 (if (= p3 "=") 0 (dr/b64-index p3))))
          (let
            ((triple (+ (* c0 262144) (* c1 4096) (* c2 64) c3)))
            (dr/b64-decode-loop
              s
              (+ i 4)
              n
              (str
                acc
                (char-from-code
                  (mod (quotient triple 65536) 256))
                (if
                  (= p2 "=")
                  ""
                  (char-from-code
                    (mod (quotient triple 256) 256)))
                (if (= p3 "=") "" (char-from-code (mod triple 256)))))))))))

(define
  dream-base64-decode
  (fn
    (s)
    (if (= s "") "" (dr/b64-decode-loop s 0 (string-length s) ""))))

;; ── Authorization header parsing ───────────────────────────────────
(define dream-authorization (fn (req) (dream-header req "authorization")))

(define
  dream-bearer-token
  (fn
    (req)
    (let
      ((a (dream-authorization req)))
      (if (and a (starts-with? a "Bearer ")) (substr a 7) nil))))

(define
  dream-basic-credentials
  (fn
    (req)
    (let
      ((a (dream-authorization req)))
      (if
        (and a (starts-with? a "Basic "))
        (let
          ((decoded (dream-base64-decode (substr a 6))))
          (let
            ((colon (index-of decoded ":")))
            (if (< colon 0) nil {:pass (substr decoded (+ colon 1)) :user (substr decoded 0 colon)})))
        nil))))

;; ── Basic auth middleware ──────────────────────────────────────────
;; check is (fn (user pass) -> bool). On success the request gains :dream-user.
(define
  dr/www-authenticate
  (fn
    (realm)
    (dream-add-header
      (dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
      "www-authenticate"
      (str "Basic realm=\"" realm "\""))))

(define
  dream-basic-auth
  (fn
    (realm check)
    (fn
      (next)
      (fn
        (req)
        (let
          ((creds (dream-basic-credentials req)))
          (if
            (and creds (check (get creds :user) (get creds :pass)))
            (next (assoc req :dream-user (get creds :user)))
            (dr/www-authenticate realm)))))))

(define dream-user (fn (req) (get req :dream-user)))

;; ── Bearer-token middleware ────────────────────────────────────────
;; check is (fn (token) -> principal | nil). On success the request gains
;; :dream-principal. Missing/invalid -> 401.
(define
  dream-require-bearer
  (fn
    (check)
    (fn
      (next)
      (fn
        (req)
        (let
          ((tok (dream-bearer-token req)))
          (let
            ((principal (if tok (check tok) nil)))
            (if
              (nil? principal)
              (dream-add-header
                (dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
                "www-authenticate"
                "Bearer")
              (next (assoc req :dream-principal principal)))))))))

(define dream-principal (fn (req) (get req :dream-principal)))