From c56fb677f8935f025cd7a6ae711fd292cbbb1581 Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Thu, 6 Aug 2026 08:52:19 +0200 Subject: [PATCH 1/2] add an RFC 7235 Auth module and Response.unauthorized http modelled every other major header family but had no authentication support at all: only Status.unauthorized (401) with a hardcoded reason, and no way to attach the WWW-Authenticate header that RFC 7235 s3.1 requires of every 401. Consumers (llm, http-client, web) each hand-roll the header. Credentials models RFC 7235 s2.1. `credentials` and `challenge` share an identical ABNF, so one type covers the Authorization and the WWW-Authenticate side alike: a scheme plus either a token68 or a list of auth-params. Params are stored as an ordered array of pairs rather than a Map so that header order survives a parse/serialize round-trip; Carp's Map iterates by bucket, which would make serialization non-deterministic. The list parser is the hard part of RFC 7235: a comma both separates auth-params within a challenge and separates challenges from each other. The scanner resolves this with one rule -- a bare token directly after a scheme is that scheme's token68, and a bare token anywhere else opens a new challenge -- which is what the grammar implies, since the token68 alternative can only follow the scheme with no comma between. Basic (RFC 7617) goes through base64.carp; Bearer (RFC 6750) is plain. Scheme matching is case-insensitive, the scheme itself is preserved as written so round-trips are byte-exact, and param values are always quoted on the way out, which the grammar permits for any of them. The parser handles attacker-controlled header values, so the scanner never indexes past the value it was given: quoted-strings that are unterminated or end in a backslash run to the end of the input, bytes that fit the grammar nowhere are dropped, and base64 that is invalid or has no colon comes back as an error. 56 new assertions, 256 total. --- README.md | 26 ++++ docs/Response.html | 24 ++++ http.carp | 293 ++++++++++++++++++++++++++++++++++++++++++- test/http.carp | 300 ++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 641 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 91bdc3e..7846c41 100644 --- a/README.md +++ b/README.md @@ -69,6 +69,30 @@ chunk framing. Detect it with `chunked?` and decode it with _ ()) ``` +### Authentication + +`Auth` parses and builds the RFC 7235 headers: the credentials a client sends in +`Authorization`, and the challenges a server answers a 401 with in +`WWW-Authenticate`. One `WWW-Authenticate` value may carry several challenges. + +```clojure +(match (Auth.parse "Basic YWxhZGRpbjpvcGVuIHNlc2FtZQ==") + (Result.Success c) + (match (Auth.basic-credentials &c) + (Result.Success up) (println* (Pair.a &up) ":" (Pair.b &up)) + (Result.Error e) (IO.errorln &e)) + (Result.Error e) (IO.errorln &e)) + +(Auth.basic "aladdin" "open sesame") +; => (Success "Basic YWxhZGRpbjpvcGVuIHNlc2FtZQ==") +(Auth.bearer "mF_9.B5f-4.1JqM") ; => "Bearer mF_9.B5f-4.1JqM" + +(let [cs (Auth.parse-challenges "Basic realm=\"a\", Digest realm=\"b\"")] + (println* (Credentials.realm (Array.unsafe-nth &cs 1)))) ; => (Just "b") + +(Response.unauthorized (Auth.basic-challenge "WallyWorld") {} @"go away") +``` + ### Status codes ```clojure @@ -88,6 +112,8 @@ Status.not-found ; => 404 | `Status` | Status code constants and reason phrases | | `Form` | URL-encoded form body parser | | `MediaType` | `Content-Type` / media-type parser (type, subtype, parameters) | +| `Auth` | `Authorization` / `WWW-Authenticate` parser and builder (RFC 7235) | +| `Credentials` | one authentication scheme with its token68 or auth-params | | `Multipart` | `multipart/form-data` body decoder | | `FormPart` | a single decoded multipart part (name, filename, content-type, body) | | `TransferEncoding` | Chunked transfer-encoding decoder | diff --git a/docs/Response.html b/docs/Response.html index 8fdbf8c..b729531 100644 --- a/docs/Response.html +++ b/docs/Response.html @@ -793,6 +793,30 @@

+
+ +

+ unauthorized +

+ +
+ defn +
+

+ (Fn [String, (Map String (Array String)), String] Response) +

+ 
+                        (unauthorized challenge headers body)
+
+

+

builds a 401 Unauthorized response carrying challenge +as its WWW-Authenticate header, which RFC 7235 §3.1 requires of every 401, +with headers and body. A WWW-Authenticate in headers is replaced. Build +challenge with Auth.basic-challenge or +Credentials.str.

+ +

+

diff --git a/http.carp b/http.carp index b3f1839..d9c0d94 100644 --- a/http.carp +++ b/http.carp @@ -1,3 +1,4 @@ +(load "git@github.com:carpentry-org/base64.carp@0.2.0") (load "git@github.com:carpentry-org/uri@0.1.0") (load "git@github.com:carpentry-org/time@0.5.0") (load "git@github.com:carpentry-org/strbuf@0.1.0") @@ -819,7 +820,18 @@ one adds none.") `Status.found`), a `Location` header of `location`, `headers`, and an empty body. A `Location` in `headers` is replaced.") (defn redirect [code location headers] - (set-header (respond code headers @"") @"Location" location))) + (set-header (respond code headers @"") @"Location" location)) + + (doc unauthorized "builds a `401 Unauthorized` response carrying `challenge` +as its `WWW-Authenticate` header, which RFC 7235 §3.1 requires of every 401, +with `headers` and `body`. A `WWW-Authenticate` in `headers` is replaced. Build +`challenge` with [Auth.basic-challenge](#basic-challenge) or +[Credentials.str](#str).") + (defn unauthorized [challenge headers body] + (set-header + (respond Status.unauthorized headers body) + @"WWW-Authenticate" + challenge))) (doc Form "provides URL-encoded form body parsing and serialization. @@ -1204,6 +1216,285 @@ numeric.") (doc private? "whether the `private` response directive is present.") (defn private? [m] (has? m "private"))) +(doc Credentials "is one RFC 7235 §2.1 `credentials` or `challenge`: an +authentication `scheme` followed by either a `token68` (`token`, e.g. the base64 +blob of a `Basic` credential) or a list of auth-`params`. Both productions have +the same grammar, so this one type models the `Authorization` and the +`WWW-Authenticate` side alike. + +`scheme` is kept as written and compared case-insensitively. Param names are +lower-cased and their values unquoted; `params` holds them in header order.") +(deftype Credentials + [scheme String + token String + params (Array (Pair String String))]) + +(defmodule Credentials + (doc scheme-is? "whether the scheme is `name`, compared case-insensitively as +RFC 7235 §2.1 requires.") + (defn scheme-is? [c name] + (= &(String.ascii-to-lower (scheme c)) &(String.ascii-to-lower name))) + + (doc param "looks up auth-param `name` (case-insensitive), returning +`(Maybe String)`.") + (defn param [c name] + (let-do [lname (String.ascii-to-lower name) + ps (params c) + len (Array.length ps) + i 0 + found (Maybe.Nothing)] + (while (and (< i len) (Maybe.nothing? &found)) + (let-do [p (Array.unsafe-nth ps i)] + (when (= (Pair.a p) &lname) (set! found (Maybe.Just @(Pair.b p)))) + (set! i (Int.inc i)))) + found)) + + (doc realm "the `realm` auth-param, as `(Maybe String)`.") + (defn realm [c] (param c "realm")) + + (hidden quote-value) + (private quote-value) + ; wraps `v` in double quotes, backslash-escaping `"` and `\`. + (defn quote-value [v] + (let-do [bs (String.to-bytes v) + len (Array.length &bs) + out (the (Array Byte) []) + quot (Char.to-byte \") + esc (Char.to-byte \\)] + (Array.push-back! &out quot) + (for [i 0 len] + (let-do [b @(Array.unsafe-nth &bs i)] + (when (or (= b quot) (= b esc)) (Array.push-back! &out esc)) + (Array.push-back! &out b))) + (Array.push-back! &out quot) + (String.from-bytes &out))) + + (doc str "serializes back into a header value, which parses back into an equal +`Credentials`. A `token` takes precedence over `params`, since RFC 7235 allows +only one of the two. Param values are always quoted, which the grammar permits +for any of them.") + (defn str [c] + (let-do [sb (StringBuf.create)] + (StringBuf.append-str &sb (scheme c)) + (if (String.empty? (token c)) + (for [i 0 (Array.length (params c))] + (let-do [p (Array.unsafe-nth (params c) i)] + (if (= i 0) + (StringBuf.append-char &sb \space) + (StringBuf.append-str &sb ", ")) + (StringBuf.append-str &sb (Pair.a p)) + (StringBuf.append-char &sb \=) + (StringBuf.append-str &sb &(quote-value (Pair.b p))))) + (do + (StringBuf.append-char &sb \space) + (StringBuf.append-str &sb (token c)))) + (let-do [s (StringBuf.to-string &sb)] (StringBuf.delete sb) s))) + (implements str Credentials.str)) + +(doc Auth "parses and builds HTTP authentication headers (RFC 7235): the +`Authorization` and `Proxy-Authorization` credentials a client sends, and the +`WWW-Authenticate` and `Proxy-Authenticate` challenges a server answers a 401 or +407 with. The `Basic` (RFC 7617) and `Bearer` (RFC 6750) schemes have dedicated +helpers. + +``` +(match (Auth.parse \"Basic YWxhZGRpbjpvcGVuIHNlc2FtZQ==\") + (Result.Success c) + (match (Auth.basic-credentials &c) + (Result.Success up) (println* (Pair.a &up) \":\" (Pair.b &up)) + (Result.Error e) (IO.errorln &e)) + (Result.Error e) (IO.errorln &e)) +```") +(defmodule Auth + (hidden tchar?) + (private tchar?) + ; whether `c` is an RFC 7230 tchar, i.e. may appear in a bare token. + (defn tchar? [c] + (or (Char.alphanum? c) (> (String.index-of "!#$%&'*+-.^_`|~" c) -1))) + + (hidden space?) + (private space?) + (defn space? [c] (let [i (Char.to-int c)] (or (= i 32) (= i 9)))) + + (hidden skip-ows) + (private skip-ows) + (defn skip-ows [s i len] + (let-do [j i] + (while (and (< j len) (space? (String.char-at s j))) (set! j (Int.inc j))) + j)) + + (hidden scan-token) + (private scan-token) + (defn scan-token [s i len] + (let-do [j i] + (while (and (< j len) (tchar? (String.char-at s j))) (set! j (Int.inc j))) + j)) + + (hidden scan-padding) + (private scan-padding) + (defn scan-padding [s i len] + (let-do [j i] + (while (and (< j len) (= (String.char-at s j) \=)) (set! j (Int.inc j))) + j)) + + (hidden scan-quoted) + (private scan-quoted) + ; scans the quoted-string at `i`, pairing the index just past it with its + ; unescaped contents; an unterminated string runs to the end of `s`. + (defn scan-quoted [s i len] + (let-do [j (Int.inc i) + out (the (Array Byte) []) + done false] + (while (and (< j len) (not done)) + (let [c (String.char-at s j)] + (cond + (= c \") (do (set! done true) (set! j (Int.inc j))) + (and (= c \\) (< (Int.inc j) len)) + (do + (Array.push-back! &out + (Char.to-byte (String.char-at s (Int.inc j)))) + (set! j (+ j 2))) + (do (Array.push-back! &out (Char.to-byte c)) (set! j (Int.inc j)))))) + (Pair.init j (String.from-bytes &out)))) + + (hidden scan) + (private scan) + ; a bare token directly after a scheme is that scheme's token68; anywhere else + ; it opens a new challenge. Bytes that fit nowhere are dropped. + (defn scan [s] + (let-do [len (String.length s) + i 0 + out (the (Array Credentials) []) + scheme @"" + token @"" + ps (the (Array (Pair String String)) []) + open false + token68-ok false] + (while (< i len) + (let [c (String.char-at s i)] + (cond + (space? c) (set! i (Int.inc i)) + (= c \,) (do (set! token68-ok false) (set! i (Int.inc i))) + (not (tchar? c)) (set! i (Int.inc i)) + (let-do [tend (scan-token s i len) + name (String.byte-slice s i tend) + j (skip-ows s tend len) + eq (and (< j len) (= (String.char-at s j) \=)) + k (if eq (skip-ows s (Int.inc j) len) j) + quoted (and eq (and (< k len) (= (String.char-at s k) \"))) + valued (and eq + (and (< k len) (tchar? (String.char-at s k))))] + (cond + (or quoted valued) + (let-do [v (if quoted + (scan-quoted s k len) + (Pair.init (scan-token s k len) @"")) + vend @(Pair.a &v)] + (when open + (Array.push-back! &ps + (Pair.init (String.ascii-to-lower &name) + (if quoted + @(Pair.b &v) + (String.byte-slice s k vend))))) + (set! token68-ok false) + (set! i vend)) + (and eq token68-ok) + (let-do [pend (scan-padding s j len)] + (set! token (String.byte-slice s i pend)) + (set! token68-ok false) + (set! i pend)) + eq + (do + (when open + (Array.push-back! &ps + (Pair.init (String.ascii-to-lower &name) + @""))) + (set! i (Int.inc j))) + token68-ok + (do (set! token @&name) (set! token68-ok false) (set! i tend)) + (do + (when open + (Array.push-back! &out + (Credentials.init @&scheme @&token @&ps))) + (set! scheme @&name) + (set! token @"") + (set! ps []) + (set! open true) + (set! token68-ok true) + (set! i tend))))))) + (when open + (Array.push-back! &out (Credentials.init @&scheme @&token @&ps))) + out)) + + (doc parse-challenges "parses a `WWW-Authenticate` or `Proxy-Authenticate` +value into its challenges, in header order. One header value may carry several +challenges, and a challenge may carry no params at all. Bytes that fit the +grammar nowhere are dropped rather than rejected, so this never fails.") + (defn parse-challenges [s] (scan s)) + + (doc parse "parses an `Authorization` or `Proxy-Authorization` value into the +one set of credentials it may carry. Fails when there is no scheme, or when more +than one scheme is present.") + (defn parse [s] + (let [cs (scan s)] + (cond + (Array.empty? &cs) (Result.Error (fmt "malformed credentials: '%s'" s)) + (> (Array.length &cs) 1) + (Result.Error (fmt "more than one scheme in credentials: '%s'" s)) + (Result.Success @(Array.unsafe-nth &cs 0))))) + + (doc basic "builds an RFC 7617 `Basic` `Authorization` value from `user` and +`password`. Fails when `user` contains a colon, which the scheme cannot +represent; a `password` may contain any number of them.") + (defn basic [user password] + (if (> (String.index-of user \:) -1) + (Result.Error @"a Basic user-id may not contain a colon") + (Result.Success + (fmt "Basic %s" &(Base64.encode-str &(fmt "%s:%s" user password)))))) + + (doc basic-credentials "decodes RFC 7617 `Basic` credentials into a user and +password `Pair`, splitting on the first colon. Fails when the scheme is not +`Basic`, the base64 does not decode, or the decoded value has no colon.") + (defn basic-credentials [c] + (if (not (Credentials.scheme-is? c "Basic")) + (Result.Error (fmt "not Basic credentials: '%s'" (Credentials.scheme c))) + (match (Base64.decode-str (Credentials.token c)) + (Result.Error e) (Result.Error e) + (Result.Success decoded) + (let [colon (String.index-of &decoded \:)] + (if (< colon 0) + (Result.Error @"Basic credentials have no colon") + (Result.Success + (Pair.init (String.byte-slice &decoded 0 colon) + (String.byte-slice &decoded + (Int.inc colon) + (String.length &decoded))))))))) + + (doc bearer "builds an RFC 6750 `Bearer` `Authorization` value from `token`.") + (defn bearer [token] (fmt "Bearer %s" token)) + + (doc bearer-token "the token of RFC 6750 `Bearer` credentials. Fails when the +scheme is not `Bearer`, or when the token is empty.") + (defn bearer-token [c] + (cond + (not (Credentials.scheme-is? c "Bearer")) + (Result.Error + (fmt "not Bearer credentials: '%s'" (Credentials.scheme c))) + (String.empty? (Credentials.token c)) (Result.Error @"empty Bearer token") + (Result.Success @(Credentials.token c)))) + + (doc basic-challenge "builds a `Basic` `WWW-Authenticate` challenge for +`realm`.") + (defn basic-challenge [realm] + (Credentials.str + &(Credentials.init @"Basic" @"" [(Pair.init @"realm" @realm)]))) + + (doc bearer-challenge "builds a `Bearer` `WWW-Authenticate` challenge for +`realm`.") + (defn bearer-challenge [realm] + (Credentials.str + &(Credentials.init @"Bearer" @"" [(Pair.init @"realm" @realm)])))) + (doc FormPart "is a single part decoded from a `multipart/form-data` body: the field `name`, an optional `filename` (present for file uploads), an optional `content-type`, and the raw `body`.") diff --git a/test/http.carp b/test/http.carp index 6e01cab..56fe664 100644 --- a/test/http.carp +++ b/test/http.carp @@ -136,6 +136,82 @@ (defn cookie-roundtrip [c] (Cookie.parse-set &(Cookie.set &c))) +; ---- auth test helpers ---- +; renders parsed challenges as `scheme token/name=value`, joined by `|` +(defn chal-summary [s] + (let-do [cs (Auth.parse-challenges s) + sb (StringBuf.create)] + (for [i 0 (Array.length &cs)] + (let-do [c (Array.unsafe-nth &cs i)] + (when (> i 0) (StringBuf.append-char &sb \|)) + (StringBuf.append-str &sb (Credentials.scheme c)) + (unless-do (String.empty? (Credentials.token c)) + (StringBuf.append-char &sb \space) + (StringBuf.append-str &sb (Credentials.token c))) + (for [j 0 (Array.length (Credentials.params c))] + (let-do [p (Array.unsafe-nth (Credentials.params c) j)] + (StringBuf.append-char &sb \/) + (StringBuf.append-str &sb (Pair.a p)) + (StringBuf.append-char &sb \=) + (StringBuf.append-str &sb (Pair.b p)))))) + (let-do [r (StringBuf.to-string &sb)] (StringBuf.delete sb) r))) + +(defn chal-count [s] (Array.length &(Auth.parse-challenges s))) + +(defn chal-realm [s i] + (let [cs (Auth.parse-challenges s)] + (if (<= (Array.length &cs) i) + @"" + (Maybe.from (Credentials.realm (Array.unsafe-nth &cs i)) @"")))) + +(defn auth-roundtrip [s] + (let-do [cs (Auth.parse-challenges s) + sb (StringBuf.create)] + (for [i 0 (Array.length &cs)] + (do + (when (> i 0) (StringBuf.append-str &sb ", ")) + (StringBuf.append-str &sb &(Credentials.str (Array.unsafe-nth &cs i))))) + (let-do [r (StringBuf.to-string &sb)] (StringBuf.delete sb) r))) + +(defn auth-scheme-is? [s name] + (match (Auth.parse s) + (Result.Success c) (Credentials.scheme-is? &c name) + (Result.Error _) false)) + +(defn basic-parts [s] + (match (Auth.parse s) + (Result.Error e) e + (Result.Success c) + (match (Auth.basic-credentials &c) + (Result.Error e) e + (Result.Success up) (fmt "%s/%s" (Pair.a &up) (Pair.b &up))))) + +(defn bearer-of [s] + (match (Auth.parse s) + (Result.Error e) e + (Result.Success c) + (match (Auth.bearer-token &c) (Result.Error e) e (Result.Success t) t))) + +(defn auth-verdict [s] + (match (Auth.parse s) (Result.Success _) @"" (Result.Error e) e)) + +(defn basic-header [u p] + (match (Auth.basic u p) (Result.Success h) h (Result.Error e) e)) + +(defn basic-header-roundtrip [u p] (basic-parts &(basic-header u p))) + +(defn repeated [s n] + (let-do [sb (StringBuf.create)] + (for [i 0 n] (StringBuf.append-str &sb s)) + (let-do [r (StringBuf.to-string &sb)] (StringBuf.delete sb) r))) + +(defn unauthorized-header [challenge headers] + (Maybe.from + (Response.header + &(Response.unauthorized challenge headers @"") + "WWW-Authenticate") + @"")) + (deftest test (assert-true test (match (Request.parse &simple-get) (Result.Success _) true _ false) @@ -1316,4 +1392,226 @@ &(expiry-verdict-at "id=abc; Expires=Fri, 24 Jul 2026 12:00:00 GMT" &(zoned 2026 7 24 11 @"EST" -18000l)) - "11:00 at UTC-5 is 16:00 GMT, after a 12:00 GMT expiry")) + "11:00 at UTC-5 is 16:00 GMT, after a 12:00 GMT expiry") + (assert-equal test + "Basic dXNlcjpwYXNz" + &(chal-summary "Basic dXNlcjpwYXNz") + "a bare token after a scheme parses as token68") + (assert-equal test + "Basic dXNlcjpwYXNz==" + &(chal-summary "Basic dXNlcjpwYXNz==") + "token68 keeps its trailing padding") + (assert-equal test + "Digest/realm=a/qop=auth" + &(chal-summary "Digest realm=\"a\", qop=\"auth\"") + "commas between auth-params stay inside one challenge") + (assert-equal test + "Digest/algorithm=MD5/nc=1" + &(chal-summary "Digest algorithm=MD5, nc=1") + "auth-param values may be bare tokens") + (assert-equal test + "Digest/qop=auth,auth-int" + &(chal-summary "Digest qop=\"auth,auth-int\"") + "a comma inside a quoted-string does not split the list") + (assert-equal test + "Newauth/realm=apps/type=1/title=Login to \"apps\"|Basic/realm=simple" + &(chal-summary + "Newauth realm=\"apps\", type=1, title=\"Login to \\\"apps\\\"\", Basic realm=\"simple\"") + "the RFC 7235 §4.1 example splits into two challenges") + (assert-equal test + "Basic/realm=a|Bearer|Digest/realm=b" + &(chal-summary "Basic realm=\"a\", Bearer, Digest realm=\"b\"") + "a challenge with no params survives between two that have them") + (assert-equal test + 3 + (chal-count "Basic realm=\"a\", Bearer, Digest realm=\"b\"") + "three challenges are found where the middle one is bare") + (assert-equal test + "Digest/realm=say \"hi\"/nonce=a\\b" + &(chal-summary "Digest realm=\"say \\\"hi\\\"\", nonce=\"a\\\\b\"") + "backslash escapes resolve inside quoted-strings") + (assert-equal test + "WallyWorld" + &(chal-realm "Basic realm=\"WallyWorld\"" 0) + "realm reads the realm auth-param") + (assert-equal test + "x" + &(chal-realm "Basic REALM=\"x\"" 0) + "auth-param names are matched case-insensitively") + (assert-equal test + "" + &(chal-realm "Bearer" 0) + "realm is Nothing for a challenge without one") + (assert-equal test + "BASIC dXNlcjpwYXNz" + &(chal-summary "BASIC dXNlcjpwYXNz") + "the scheme is preserved exactly as written") + (assert-true test + (auth-scheme-is? "BaSiC dXNlcjpwYXNz" "basic") + "scheme matching is case-insensitive") + (assert-false test + (auth-scheme-is? "Bearer abc" "basic") + "scheme matching rejects a different scheme") + (assert-equal test + "Basic realm=\"WallyWorld\"" + &(auth-roundtrip "Basic realm=\"WallyWorld\"") + "a challenge round-trips through the serializer") + (assert-equal test + "Basic dXNlcjpwYXNz==" + &(auth-roundtrip "Basic dXNlcjpwYXNz==") + "token68 round-trips through the serializer") + (assert-equal test + "Basic realm=\"a\", Bearer, Digest realm=\"b\"" + &(auth-roundtrip "Basic realm=\"a\", Bearer, Digest realm=\"b\"") + "a challenge list round-trips, bare challenge included") + (assert-equal test + "Digest realm=\"say \\\"hi\\\"\"" + &(auth-roundtrip "Digest realm=\"say \\\"hi\\\"\"") + "quotes in a param value are re-escaped on serialization") + (assert-equal test + "Digest algorithm=\"MD5\"" + &(auth-roundtrip "Digest algorithm=MD5") + "an unquoted param value is quoted on serialization") + (assert-equal test + "Basic dXNlcjpwYXNz" + &(basic-header "user" "pass") + "Auth.basic base64-encodes user and password") + (assert-equal test + "user/pass" + &(basic-header-roundtrip "user" "pass") + "Basic credentials round-trip through parse and decode") + (assert-equal test + "user/pa:ss:word" + &(basic-header-roundtrip "user" "pa:ss:word") + "a password may contain colons, which stay in the password") + (assert-equal test + "user/" + &(basic-header-roundtrip "user" "") + "an empty password round-trips") + (assert-equal test + "a Basic user-id may not contain a colon" + &(basic-header "us:er" "pass") + "Auth.basic rejects a user-id containing a colon") + (assert-equal test + "Basic credentials have no colon" + &(basic-parts "Basic aaaa") + "base64 that decodes without a colon is a clean failure") + (assert-equal test + "Basic credentials have no colon" + &(basic-parts "Basic") + "a lone Basic scheme is a clean failure") + (assert-equal test + "input length must be a multiple of 4" + &(basic-parts "Basic !!!") + "invalid base64 is a clean failure") + (assert-equal test + "not Basic credentials: 'Bearer'" + &(basic-parts "Bearer abc") + "basic-credentials rejects another scheme") + (assert-equal test + "Bearer abc123" + &(Auth.bearer "abc123") + "Auth.bearer builds a Bearer header value") + (assert-equal test + "abc123" + &(bearer-of "Bearer abc123") + "bearer-token reads the token back") + (assert-equal test + "abc123" + &(bearer-of "bearer abc123") + "bearer-token accepts a lower-cased scheme") + (assert-equal test + "empty Bearer token" + &(bearer-of "Bearer") + "bearer-token rejects a scheme with no token") + (assert-equal test + "not Bearer credentials: 'Basic'" + &(bearer-of "Basic dXNlcjpwYXNz") + "bearer-token rejects another scheme") + (assert-equal test + "Basic realm=\"WallyWorld\"" + &(Auth.basic-challenge "WallyWorld") + "basic-challenge builds a WWW-Authenticate value") + (assert-equal test + "Basic realm=\"say \\\"hi\\\"\"" + &(Auth.basic-challenge "say \"hi\"") + "basic-challenge escapes quotes in the realm") + (assert-equal test + "Bearer realm=\"api\"" + &(Auth.bearer-challenge "api") + "bearer-challenge builds a WWW-Authenticate value") + (assert-equal test + "malformed credentials: ''" + &(auth-verdict "") + "Auth.parse rejects an empty value") + (assert-equal test + "malformed credentials: ' '" + &(auth-verdict " ") + "Auth.parse rejects a whitespace-only value") + (assert-equal test + "more than one scheme in credentials: 'Basic abc, Bearer def'" + &(auth-verdict "Basic abc, Bearer def") + "Auth.parse rejects more than one scheme") + (assert-equal test + "" + &(auth-verdict "Basic") + "Auth.parse accepts a scheme with no credentials") + (assert-equal test + 0 + (chal-count "") + "an empty header value yields no challenges") + (assert-equal test + 0 + (chal-count " \t ") + "a whitespace-only header value yields no challenges") + (assert-equal test 0 (chal-count ",,,") "commas alone yield no challenges") + (assert-equal test + 0 + (chal-count "=") + "a stray equals sign yields no challenges") + (assert-equal test + "Basic" + &(chal-summary "Basic ,") + "a trailing comma does not invent a challenge") + (assert-equal test + "Basic/realm=unterminated" + &(chal-summary "Basic realm=\"unterminated") + "an unterminated quoted-string runs to the end of the value") + (assert-equal test + "Basic/realm=a\\" + &(chal-summary "Basic realm=\"a\\") + "a trailing backslash inside a quoted-string is kept literally") + (assert-equal test + "Basic/realm=/foo=" + &(chal-summary "Basic realm=\"\", foo=") + "empty param values parse as empty") + (assert-equal test + "Basic" + &(chal-summary "Basic éé") + "non-ASCII bytes outside a quoted-string are dropped") + (assert-equal test + "Basic/realm=é" + &(chal-summary "Basic realm=\"é\"") + "non-ASCII bytes inside a quoted-string are preserved") + (assert-equal test + 1 + (chal-count &(fmt "Basic realm=\"%s\"" &(repeated "a" 20000))) + "a very long header value parses without crashing") + (assert-equal test + 0 + (chal-count &(repeated "\\\"=," 5000)) + "a long run of delimiters parses without crashing") + (assert-equal test + 401 + @(Response.code + &(Response.unauthorized (Auth.basic-challenge "site") {} @"")) + "Response.unauthorized is a 401") + (assert-equal test + "Basic realm=\"site\"" + &(unauthorized-header (Auth.basic-challenge "site") {}) + "Response.unauthorized attaches the challenge") + (assert-equal test + "Basic realm=\"new\"" + &(unauthorized-header (Auth.basic-challenge "new") + {@"WWW-Authenticate" [@"Basic realm=\"old\""]}) + "Response.unauthorized replaces a WWW-Authenticate in headers")) From c90286098834edd01df0729b082539cfac906771 Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Thu, 6 Aug 2026 14:17:37 +0200 Subject: [PATCH 2/2] scan token68 with the RFC 7235 alphabet, not the RFC 7230 tchar set MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit token68 is a different production from token: RFC 7235 §2.1 and RFC 6750 §2.1 both give it as 1*( ALPHA / DIGIT / "-" / "." / "_" / "~" / "+" / "/" ) *"=". Every one of those is a tchar except "/", which is in the standard base64 alphabet Base64.encode-str emits — so the module could not read its own output: Auth.basic "u" "aaa?" => Basic dTphYWE/ Auth.parse "Basic dTphYWE/" => token 'dTphYWE', truncated at the / Auth.basic-credentials => "input length must be a multiple of 4" and a standard-alphabet Bearer token was read as two challenges. Roughly one Basic login in twenty is affected. The wider set applies only where token68-ok holds, so "realm=\"a\"" keeps the auth-param branch and "dXNlcjpwYXNz==" keeps the padding branch; "=" stays out of it for the same reason. Both the dispatch and the scan are widened, so a token68 may also begin with a slash rather than silently losing it. Seven assertions added, 256 -> 263. Five of them fail without the fix; the other two pin that the fixture really contains a slash and that the wider alphabet does not reach an auth-param value. --- http.carp | 20 ++++++++++++++++++-- test/http.carp | 28 ++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 2 deletions(-) diff --git a/http.carp b/http.carp index d9c0d94..71e72e7 100644 --- a/http.carp +++ b/http.carp @@ -1312,6 +1312,11 @@ helpers. (defn tchar? [c] (or (Char.alphanum? c) (> (String.index-of "!#$%&'*+-.^_`|~" c) -1))) + (hidden token68-char?) + (private token68-char?) + ; whether `c` may appear in an RFC 7235 token68, which allows `/`. + (defn token68-char? [c] (or (tchar? c) (= c \/))) + (hidden space?) (private space?) (defn space? [c] (let [i (Char.to-int c)] (or (= i 32) (= i 9)))) @@ -1330,6 +1335,14 @@ helpers. (while (and (< j len) (tchar? (String.char-at s j))) (set! j (Int.inc j))) j)) + (hidden scan-token68) + (private scan-token68) + (defn scan-token68 [s i len] + (let-do [j i] + (while (and (< j len) (token68-char? (String.char-at s j))) + (set! j (Int.inc j))) + j)) + (hidden scan-padding) (private scan-padding) (defn scan-padding [s i len] @@ -1375,8 +1388,11 @@ helpers. (cond (space? c) (set! i (Int.inc i)) (= c \,) (do (set! token68-ok false) (set! i (Int.inc i))) - (not (tchar? c)) (set! i (Int.inc i)) - (let-do [tend (scan-token s i len) + (not (if token68-ok (token68-char? c) (tchar? c))) + (set! i (Int.inc i)) + (let-do [tend (if token68-ok + (scan-token68 s i len) + (scan-token s i len)) name (String.byte-slice s i tend) j (skip-ows s tend len) eq (and (< j len) (= (String.char-at s j) \=)) diff --git a/test/http.carp b/test/http.carp index 56fe664..c736584 100644 --- a/test/http.carp +++ b/test/http.carp @@ -1401,6 +1401,14 @@ "Basic dXNlcjpwYXNz==" &(chal-summary "Basic dXNlcjpwYXNz==") "token68 keeps its trailing padding") + (assert-equal test + "Basic dTphYWE/" + &(chal-summary "Basic dTphYWE/") + "a token68 keeps a slash, which the token grammar excludes") + (assert-equal test + "Digest/realm=a|b" + &(chal-summary "Digest realm=a/b") + "the wider token68 alphabet does not reach an auth-param value") (assert-equal test "Digest/realm=a/qop=auth" &(chal-summary "Digest realm=\"a\", qop=\"auth\"") @@ -1480,6 +1488,14 @@ "user/pass" &(basic-header-roundtrip "user" "pass") "Basic credentials round-trip through parse and decode") + (assert-equal test + "Basic dTphYWE/" + &(basic-header "u" "aaa?") + "Auth.basic emits the standard base64 alphabet, slash included") + (assert-equal test + "u/aaa?" + &(basic-header-roundtrip "u" "aaa?") + "Basic credentials whose base64 contains a slash round-trip") (assert-equal test "user/pa:ss:word" &(basic-header-roundtrip "user" "pa:ss:word") @@ -1520,6 +1536,18 @@ "abc123" &(bearer-of "bearer abc123") "bearer-token accepts a lower-cased scheme") + (assert-equal test + "ab/cd.ef/gh" + &(bearer-of "Bearer ab/cd.ef/gh") + "a Bearer token may contain slashes") + (assert-equal test + 1 + (chal-count "Bearer ab/cd.ef/gh") + "a slash does not split a Bearer token into two challenges") + (assert-equal test + "/abc" + &(bearer-of "Bearer /abc") + "a token68 may begin with a slash") (assert-equal test "empty Bearer token" &(bearer-of "Bearer")