dream: auth — pure-SX base64 + HTTP Basic + Bearer-token middleware + 23 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m11s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m11s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
172
lib/dream/auth.sx
Normal file
172
lib/dream/auth.sx
Normal file
@@ -0,0 +1,172 @@
|
||||
;; 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)))
|
||||
@@ -33,6 +33,7 @@ MODULES=(
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/cors.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/run.sx"
|
||||
"lib/dream/api.sx"
|
||||
"lib/dream/demos/hello.sx"
|
||||
@@ -54,6 +55,7 @@ SUITES=(
|
||||
"error dream-er-tests-run! lib/dream/tests/error.sx"
|
||||
"cors dream-co-tests-run! lib/dream/tests/cors.sx"
|
||||
"json dream-js-tests-run! lib/dream/tests/json.sx"
|
||||
"auth dream-au-tests-run! lib/dream/tests/auth.sx"
|
||||
"run dream-rn-tests-run! lib/dream/tests/run.sx"
|
||||
"api dream-ap-tests-run! lib/dream/tests/api.sx"
|
||||
"demos dream-dm-tests-run! lib/dream/tests/demos.sx"
|
||||
|
||||
109
lib/dream/tests/auth.sx
Normal file
109
lib/dream/tests/auth.sx
Normal file
@@ -0,0 +1,109 @@
|
||||
;; lib/dream/tests/auth.sx — base64, basic auth, bearer tokens.
|
||||
|
||||
(define dream-au-pass 0)
|
||||
(define dream-au-fail 0)
|
||||
(define dream-au-fails (list))
|
||||
|
||||
(define
|
||||
dream-au-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-au-pass (+ dream-au-pass 1))
|
||||
(begin
|
||||
(set! dream-au-fail (+ dream-au-fail 1))
|
||||
(append! dream-au-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── base64 ─────────────────────────────────────────────────────────
|
||||
(dream-au-test "encode Man" (dream-base64-encode "Man") "TWFu")
|
||||
(dream-au-test "encode Ma" (dream-base64-encode "Ma") "TWE=")
|
||||
(dream-au-test "encode M" (dream-base64-encode "M") "TQ==")
|
||||
(dream-au-test
|
||||
"encode user:pass"
|
||||
(dream-base64-encode "user:pass")
|
||||
"dXNlcjpwYXNz")
|
||||
(dream-au-test "decode Man" (dream-base64-decode "TWFu") "Man")
|
||||
(dream-au-test "decode Ma" (dream-base64-decode "TWE=") "Ma")
|
||||
(dream-au-test "decode M" (dream-base64-decode "TQ==") "M")
|
||||
(dream-au-test
|
||||
"decode user:pass"
|
||||
(dream-base64-decode "dXNlcjpwYXNz")
|
||||
"user:pass")
|
||||
(dream-au-test
|
||||
"roundtrip phrase"
|
||||
(dream-base64-decode (dream-base64-encode "Hello, World!"))
|
||||
"Hello, World!")
|
||||
(dream-au-test
|
||||
"roundtrip empty"
|
||||
(dream-base64-decode (dream-base64-encode ""))
|
||||
"")
|
||||
|
||||
;; ── header parsing ─────────────────────────────────────────────────
|
||||
(dream-au-test
|
||||
"bearer token"
|
||||
(dream-bearer-token (dream-request "GET" "/" {:Authorization "Bearer abc.123"} ""))
|
||||
"abc.123")
|
||||
(dream-au-test
|
||||
"no bearer"
|
||||
(dream-bearer-token (dream-request "GET" "/" {} ""))
|
||||
nil)
|
||||
(dream-au-test
|
||||
"basic creds"
|
||||
(dream-basic-credentials (dream-request "GET" "/" {:Authorization "Basic dXNlcjpwYXNz"} ""))
|
||||
{:pass "pass" :user "user"})
|
||||
(dream-au-test
|
||||
"no basic"
|
||||
(dream-basic-credentials (dream-request "GET" "/" {} ""))
|
||||
nil)
|
||||
|
||||
;; ── basic auth middleware ──────────────────────────────────────────
|
||||
(define dream-au-check (fn (u p) (and (= u "admin") (= p "secret"))))
|
||||
(define
|
||||
dream-au-app
|
||||
((dream-basic-auth "Admin Area" dream-au-check)
|
||||
(fn (req) (dream-text (str "hi " (dream-user req))))))
|
||||
|
||||
(define dream-au-ok (dream-au-app (dream-request "GET" "/" {:Authorization (str "Basic " (dream-base64-encode "admin:secret"))} "")))
|
||||
(dream-au-test "basic ok reaches" (dream-resp-body dream-au-ok) "hi admin")
|
||||
(dream-au-test "basic ok status" (dream-status dream-au-ok) 200)
|
||||
|
||||
(define dream-au-bad (dream-au-app (dream-request "GET" "/" {:Authorization (str "Basic " (dream-base64-encode "admin:wrong"))} "")))
|
||||
(dream-au-test "basic wrong 401" (dream-status dream-au-bad) 401)
|
||||
(dream-au-test
|
||||
"basic wrong www-authenticate"
|
||||
(contains? (dream-resp-header dream-au-bad "www-authenticate") "Admin Area")
|
||||
true)
|
||||
(dream-au-test
|
||||
"basic missing 401"
|
||||
(dream-status (dream-au-app (dream-request "GET" "/" {} "")))
|
||||
401)
|
||||
|
||||
;; ── bearer middleware ──────────────────────────────────────────────
|
||||
(define dream-au-tokens {:t-ada "ada" :t-bob "bob"})
|
||||
(define dream-au-lookup (fn (tok) (get dream-au-tokens tok)))
|
||||
(define
|
||||
dream-au-bapp
|
||||
((dream-require-bearer dream-au-lookup)
|
||||
(fn (req) (dream-text (dream-principal req)))))
|
||||
|
||||
(dream-au-test
|
||||
"bearer valid principal"
|
||||
(dream-resp-body (dream-au-bapp (dream-request "GET" "/" {:Authorization "Bearer t-ada"} "")))
|
||||
"ada")
|
||||
(dream-au-test
|
||||
"bearer invalid 401"
|
||||
(dream-status (dream-au-bapp (dream-request "GET" "/" {:Authorization "Bearer nope"} "")))
|
||||
401)
|
||||
(dream-au-test
|
||||
"bearer missing 401"
|
||||
(dream-status (dream-au-bapp (dream-request "GET" "/" {} "")))
|
||||
401)
|
||||
(dream-au-test
|
||||
"bearer 401 header"
|
||||
(dream-resp-header
|
||||
(dream-au-bapp (dream-request "GET" "/" {} ""))
|
||||
"www-authenticate")
|
||||
"Bearer")
|
||||
|
||||
(define dream-au-tests-run! (fn () {:total (+ dream-au-pass dream-au-fail) :passed dream-au-pass :failed dream-au-fail :fails dream-au-fails}))
|
||||
@@ -130,6 +130,12 @@ with extensions + hardening below.
|
||||
`dream-serve`/`dream-serve-port`. `lib/dream/README.md` documents the full public
|
||||
surface, quickstart, the dependency-injection testing story, and caveats. **All
|
||||
planned extensions complete — 367/367 across 14 suites.**
|
||||
- **2026-06-07 — Ext: auth** (`lib/dream/auth.sx`, 23 tests, 390 total). Pure-SX base64
|
||||
codec (`dream-base64-encode`/`-decode`, arithmetic via `quotient`/`mod` — no bitwise),
|
||||
verified against RFC vectors (Man/Ma/M padding). `dream-basic-auth realm check` →
|
||||
401 + `WWW-Authenticate: Basic realm=…`, attaches `:dream-user` on success;
|
||||
`dream-basic-credentials` / `dream-authorization` accessors. `dream-require-bearer
|
||||
check` → attaches `:dream-principal` or 401; `dream-bearer-token` accessor.
|
||||
|
||||
## Extensions (post-roadmap)
|
||||
|
||||
@@ -144,6 +150,7 @@ The five-types core is complete; these harden it toward a production HTTP front
|
||||
- [x] **JSON helpers** (encode + recursive-descent parse, pure SX).
|
||||
- [x] **Query/header convenience** (`dream-queries`, `*-or` defaults, `dream-accepts?`).
|
||||
- [x] **`api.sx` facade + README** — `dream-make-app` / `dream-serve` + `README.md`.
|
||||
- [x] **Auth** — base64 (pure SX), HTTP Basic auth + Bearer-token middleware.
|
||||
|
||||
## Stdlib additions Dream will need
|
||||
|
||||
|
||||
Reference in New Issue
Block a user