;;;; Header value accessor procedures ;; Get the raw contents of a header (define (header-contents name headers #!optional default) (alist-ref name (headers-v headers) eq? default)) ;; Get all values of a header (define (header-values header-name headers) (map (cut vector-ref <> 0) (header-contents header-name headers '()))) ;; Get the value of a header, assuming it has only one value (define (header-value header-name headers #!optional default) (let ((contents (header-contents header-name headers '()))) (if (null? contents) default (get-value (car contents))))) ;; Get the parameters of a header, assuming it has only one value (define (header-params header-name headers) (let ((contents (header-contents header-name headers '()))) (if (null? contents) '() (get-params (car contents))))) ;; Get a specific parameter of a header, assuming it has only one value (define (header-param param-name header-name headers #!optional default) (alist-ref param-name (header-params header-name headers) eq? default)) ;; Get the value from one header entry (define get-value (cut vector-ref <> 0)) ;; Get all params from one header entry (define get-params (cut vector-ref <> 1)) ;; Get one specific parameter from one header entry (define (get-param param contents #!optional (default #f)) (alist-ref param (vector-ref contents 1) eq? default)) ;;;; Header parsers (define (single subparser #!optional (parameter-subparsers '())) (lambda (contents) (list ((with-params subparser parameter-subparsers) contents)))) (define (multiple subparser #!optional (parameter-subparsers '())) (lambda (contents) (map (with-params subparser parameter-subparsers) (split-multi-header contents)))) ;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens (define (split-multi-header value) (let ((len (string-length value))) (let loop ((result '()) (start-pos 0) ; Where the current header value starts (search-pos 0)) ; Where the searching starts (or (and-let* (((< search-pos len)) (pos (string-index value (char-set #\, #\") search-pos))) (if (char=? #\, (string-ref value pos)) (loop (cons (string-copy value start-pos pos) result) (add1 pos) (add1 pos)) (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\")))) (loop result start-pos (add1 end-pos))))) (reverse (cons (string-drop value start-pos) result)))))) ;; Remove all escape characters from the input, recognising "escaped escapes" (define (unescape str) (let ((last-char (sub1 (string-length str)))) (let loop ((result "") (start-pos 0)) (or (and-let* ((pos (string-index str #\\ start-pos))) (if (= pos last-char) (string-append result (string-copy str start-pos)) (loop (string-append result (string-copy str start-pos pos) (string-copy str (add1 pos) (+ pos 2))) (+ pos 2)))) (string-append result (string-copy str start-pos)))))) ;; Find a matching endpoint for a token, ignoring escaped copies of the token (define (escaped-string-end str start stop-char-set) (let ((len (string-length str))) (let loop ((start start)) (let ((pos (string-index str (char-set-adjoin stop-char-set #\\) start))) (if pos (if (char=? #\\ (string-ref str pos)) ;; Escaped matching closing symbol (if (= len (add1 pos)) pos (loop (+ pos 2))) ;; Reached the matching closing symbol pos) len))))) ; No matching closing symbol? "Insert" it at the end ;; Try to parse a token, starting at the provided offset, up until the ;; char-set where we should stop. Returns two values: the token or #f if ;; there is no token left, and the position on which the token ends. (define (parse-token value start-pos stop-char-set) (if (>= start-pos (string-length value)) (values #f start-pos) (let ((stop (char-set-adjoin stop-char-set #\"))) (let ((pos (string-index value stop start-pos))) (if pos (if (not (char=? #\" (string-ref value pos))) (values (string-trim-both (string-copy value start-pos pos)) pos) ; Stop-char found, but no quoting (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\")))) ;; Found the double quote? Recurse on the remainder (receive (rest final-pos) (parse-token value (add1 end-pos) stop-char-set) (values (string-append (string-trim-both (string-copy value start-pos pos)) (if (= pos end-pos) (unescape (string-copy value (add1 pos))) (unescape (string-copy value (add1 pos) end-pos))) (or rest "")) final-pos)))) ;; Nothing found? Then the remainder of the string is the token (values (string-trim-both (string-copy value start-pos)) (string-length value))))))) ;; Comments are a bit like tokens, except they can be nested (define (parse-comment value start-pos) (let* ((len (string-length value)) (nospace-pos (and (< start-pos len) (string-skip value char-set:whitespace start-pos)))) (if (and nospace-pos (char=? (string-ref value nospace-pos) #\()) (let loop ((result "") (start-pos (add1 nospace-pos))) (if (>= start-pos len) (values result len) (let ((pos (string-index value (char-set #\( #\)) start-pos))) (if pos (if (char=? #\( (string-ref value pos)) ; Nested comment (receive (nested end-pos) (parse-comment value pos) (loop (sprintf "~A~A(~A)" result (string-copy value start-pos pos) nested) (add1 end-pos))) ;; Else it's a ) (values (conc result (string-copy value start-pos pos)) (add1 pos))) ;; Nothing found? Then the remainder of the string is the token (values (conc result (string-copy value start-pos)) (string-length value)))))) ;; No (? Then fail to match the 'comment' (values #f start-pos)))) (define (parse-parameters string start-pos param-subparsers #!optional (stop-set (char-set #\;))) (let loop ((start-pos start-pos) (params '())) (receive (attribute-name pos) (parse-token string start-pos (char-set-union stop-set (char-set #\=))) (if attribute-name (let ((attribute (http-name->symbol attribute-name))) (if (and (< pos (string-length string)) (char=? (string-ref string pos) #\=)) (receive (value pos) (parse-token string (add1 pos) stop-set) ;; In case of no value ("foo="), use the empty string as value (let ((value ((alist-ref attribute param-subparsers eq? identity) (or value "")))) (loop (add1 pos) (cons (cons attribute value) params)))) ;; Missing value is interpreted as "present", ;; so #t. If not present, it's #f when looking it up (loop (add1 pos) (cons (cons attribute #t) params)))) (values (reverse params) pos))))) (define (parse-value+parameters string start-pos value-subparser param-subparsers) (receive (value pos) (parse-token string start-pos (char-set #\;)) (if (not value) (values #f pos) ;; XXX this is wrong and not expected by the caller! (receive (params pos) (parse-parameters string (add1 pos) param-subparsers) (values (vector (value-subparser value) params) pos))))) (define (with-params value-subparser parameter-subparsers) (lambda (entry) (receive (type+params pos) (parse-value+parameters entry 0 value-subparser parameter-subparsers) type+params))) (define (make-key/value-subparser key/value-subparsers) (lambda (k/v) ;; We're abusing parse-parameters here to read value ;; instead of params. This is weird, but it works :) (receive (key+value pos) (parse-parameters k/v 0 key/value-subparsers) (vector (car key+value) '())))) ;; There's only one key/value pair (foreign-declare "#include ") (define-foreign-variable LC_TIME int) (define setlocale (foreign-lambda c-string setlocale int c-string)) (define-syntax let-locale (syntax-rules () ((let-locale ((cat val) ...) body ...) (let ((backup '())) (dynamic-wind (lambda () (set! backup `((cat . ,(setlocale cat val)) ...))) (lambda () body ...) (lambda () (setlocale cat (alist-ref 'cat backup)) ...)))))) (define (make-date->string-parser spec) (let ((regex (string-translate* spec '((" " . " +") ; Any number of spaces is very permissive ("%a" . "(Sun|Mon|Tue|Wed|Thu|Fri|Sat)") ("%A" . "(Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday)") ("%d" . "[0-9]{1,2}") ("%b" . "(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)") ("%y" . "[0-9]{1,2}") ("%Y" . "[0-9]{4}") ("%X" . "[0-9]{2}:[0-9]{2}:[0-9]{2}"))))) (lambda (str) (and (string-search regex str) (let-locale ((LC_TIME "POSIX")) (string->time str spec)))))) (define rfc1123-string->time (make-date->string-parser "%a, %d %b %Y %X GMT")) ;; This is a little more relaxed than strict rfc850 (it allows abbreviated ;; weekdays) - for example Google Web Server outputs cookies in this format. (define rfc850-string->time (disjoin (make-date->string-parser "%A, %d-%b-%y %X GMT") (make-date->string-parser "%a, %d-%b-%Y %X GMT"))) (define asctime-string->time (make-date->string-parser "%a %b %d %X %Y")) (define http-date-string->time (disjoin rfc1123-string->time rfc850-string->time asctime-string->time)) (define (rfc1123-subparser str) (or (rfc1123-string->time str) (signal-http-condition "Error parsing RFC 1123 date/time" 'rfc1123-subparser 'value str))) (define (rfc850-subparser str) (or (rfc850-string->time str) (signal-http-condition "Error parsing RFC850 date/time" 'rfc850-subparser 'value str))) (define (asctime-subparser str) (or (asctime-string->time str) (signal-http-condition "Error parsing asctime() date/time" 'asctime-subparser 'value str))) ;; rfc1123-date | rfc850-date | asctime-date (define (http-date-subparser str) (or (http-date-string->time str) (signal-http-condition "Error parsing date/time" 'http-date-subparser 'value str))) ;; Change the accuracy of a number to 'digits' number of digits to the ;; right of the decimal point. (define (chop-number num digits) (let ((factor (expt 10 digits))) (/ (round (* num factor)) factor))) (define (quality-subparser str) ;; Anything that's not a number is seen as if the value is missing, hence 1.0 (let* ((num (or (string->number str) 1.0)) (imprecise (chop-number num 3))) (max 0.0 (min 1.0 imprecise)))) ;; Just put all header strings in a list, so we can pass it on ;; Make no assumptions about the contents (only value, don't try to parse params) ;; This is different from (multiple (without-params generic-header-parser)) ;; because this does not assume it can split up comma-separated values (define (unknown-header-parser contents) (list (vector contents '()))) (define symbol-subparser (compose string->symbol string-trim-both)) (define symbol-subparser-ci (compose string->symbol string-trim-both string-downcase)) (define (natnum-subparser contents) (let ((num (string->number contents))) (if num (inexact->exact (max 0 (round num))) 0))) (define (host/port-subparser contents) (let* ((idx (string-index-right contents #\:)) (portnum (and idx (string->number (substring/shared contents (add1 idx)))))) (if (and idx portnum) (cons (substring/shared contents 0 idx) (inexact->exact (round portnum))) (cons contents #f)))) ; base64 of 128 bit hex digest as per RFC1864 (eg, Content-md5) (define base64-subparser base64-decode) ;; bytes -/ (define (range-subparser s) (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s))) (map string->number (drop parts 1)))) ;; [W/] ;; This is a full parser, because it needs to be able to distinguish ;; between W/"foo" and "W/foo". If it's preprocessed by the tokenizer ;; both get "normalised" to the same thing: W/foo ;; ;; XXX It could be a good idea if the single/multiple token parsers ;; did not do anything to their contents. If the consuming parsers ;; want tokens, they know how to have it. OTOH, it would mean much ;; more code for all the parsers as they need to tokenize more... (define (etag-parser contents) (let ((contents (string-trim-both contents))) (list (vector (if (string-prefix? "W/" contents) `(weak . ,(parse-token contents 2 char-set:whitespace)) `(strong . ,(parse-token contents 0 char-set:whitespace))) '())))) ;; Used for both if-match and if-none-match ;; This is either a wilcard ('*') or several entities (define (if-match-parser contents) (let ((contents (string-trim-both contents))) (if (string=? "*" contents) (list (vector '* '())) (let loop ((pos 0) (etags '())) (let ((weak (string-prefix? "W/" contents 0 2 pos))) (receive (etag newpos) (parse-token contents (+ pos (if weak 2 0)) char-set:whitespace) (let ((newpos (string-skip contents char-set:whitespace newpos)) (value (and etag (vector (cons (if weak 'weak 'strong) etag) '())))) (if value (if newpos (loop newpos (cons value etags)) (reverse! (cons value etags))) (reverse! etags))))))))) ;; ( [/] [] )+ ;; This parser is a full parser because parse-token cannot handle ;; comments yet... (if a ; is in a comment, it breaks down) (define (product-parser contents) (let loop ((start-pos 0) (products '())) (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\())) ((version pos2) (parse-token contents pos ; (add1 pos) (char-set-union (char-set #\() char-set:whitespace))) ((comment pos3) (parse-comment contents pos2)) ;; Ugh ((real-version) (and version (not (string-null? version)) (string-trim version #\/)))) (if product (loop pos3 (cons (list product real-version comment) products)) (list (vector (reverse products) '())))))) ;;;; MAJOR TODOs ;; RFC1123 mailbox parser - just strings for now (define mailbox-subparser identity) ;; Either an entity-tag or a http-date (define (if-range-parser contents) (let ((http-date ((with-params http-date-string->time '()) contents))) (if (get-value http-date) (list http-date) (etag-parser contents)))) ;; Either delta-seconds or http-date (define retry-after-subparser (disjoin http-date-subparser natnum-subparser)) ;; Tricky - see 2616 14.45 ;; We probably shouldn't try to do too much parsing here (define via-parser split-multi-header) ;; Tricky - see 2616 14.46 (define warning-parser split-multi-header) ;;;; END MAJOR TODOs (define (key/value-subparser str) (let ((idx (string-index str #\=))) (cons (string->symbol (string-take str idx)) (string-drop str (add1 idx))))) ;; The 'expires' header defined by the Netscape cookie spec contains ;; an embedded comma. RFC 2109 cookies use Max-Age instead. (define (old-style-cookie? cookie) (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie)) (define (string->number-list str) (map string->number (string-split str ","))) (define (relative-ref/path-only s) (and-let* ((ref (uri-reference s)) ((not (uri-host ref))) ((null? (uri-query ref))) ((not (uri-fragment ref)))) ref)) ;; We're using http-date-subparser for 'expires' instead of rfc850-subparser ;; (which would be the correct thing to do) because several well-known web ;; server software packages (tested: PHP and Rails) get it wrong. So we ;; will go by the robustness principle and allow any kind of HTTP date. (define set-cookie-parser (let ((param-subparsers `((expires . ,http-date-subparser) (max-age . ,string->number) (version . ,string->number) (port . ,string->number-list) (path . ,relative-ref/path-only))) (name/value-parser (lambda (str) (let ((idx (string-index str #\=))) (cons (string-take str idx) (string-drop str (add1 idx))))))) (lambda (contents) (if (old-style-cookie? contents) (list ((with-params name/value-parser param-subparsers) contents)) (map (with-params name/value-parser param-subparsers) (split-multi-header contents)))))) (define cache-control-parser (let ((splitter (lambda (str) ;; Is this correct? (map (compose string->symbol string-trim-both) (string-split str ","))))) (lambda (contents) (map (make-key/value-subparser `((max-age . ,natnum-subparser) (s-maxage . ,natnum-subparser) (max-stale . ,natnum-subparser) (min-fresh . ,natnum-subparser) (private . ,splitter) (no-cache . ,splitter))) (split-multi-header contents))))) (define (authorization-parser contents) (let loop ((pos 0) (result '())) (receive (authtype pos) (parse-token contents pos char-set:whitespace) (if (not authtype) (reverse result) (let ((authtype (http-name->symbol authtype))) (case authtype ((basic) (receive (secret pos) (parse-token contents (add1 pos) (char-set #\,)) (let* ((decoded (base64-decode secret)) (colon-idx (string-index decoded #\:)) (user (string-take decoded colon-idx)) (pass (string-drop decoded (add1 colon-idx)))) (loop (add1 pos) (cons (vector authtype `((username . ,user) (password . ,pass))) result))))) ((digest) (receive (params pos) (parse-parameters contents pos `((nc . ,(lambda (n) (string->number n 16))) (uri . ,uri-reference) (qop . ,symbol-subparser) (algorithm . ,symbol-subparser-ci)) (char-set #\,)) (loop (add1 pos) (cons (vector authtype params) result)))) (else (receive (params pos) (parse-parameters contents (add1 pos) '()) (loop (add1 pos) (cons (vector authtype params) result)))))))))) (define (authenticate-parser contents) (let loop ((pos 0) (result '())) (receive (authtype pos) (parse-token contents pos char-set:whitespace) (if (not authtype) (reverse result) (let ((authtype (http-name->symbol authtype))) (receive (params pos) (parse-parameters contents pos `((domain . ,(lambda (s) (map uri-reference (string-split s)))) (qop . ,(lambda (s) (map (compose symbol-subparser string-trim) (string-split s ",")))) (algorithm . ,symbol-subparser-ci) (stale . ,(lambda (s) (string-ci=? (string-trim s) "TRUE")))) (char-set #\,)) (loop (add1 pos) (cons (vector authtype params) result)))))))) (define (pragma-parser contents) (map (make-key/value-subparser `()) (split-multi-header contents))) (define (te-parser contents) (map (make-key/value-subparser `((q . ,quality-subparser))) (split-multi-header contents))) ;; Cookie headers are also braindead: there can be several cookies in one header, ;; separated by either commas or semicolons. The only way to distinguish a ;; new cookie from a parameter of the current cookie is the dollar in front ;; of all parameter names. ;; Also, there's a $Version attribute that prepends all cookies, which is ;; considered to apply to all cookies that follow. (define (cookie-parser contents) ;; Local version of parse-parameters that stops when param without $ is seen (define (read-params start-pos) (let next-param ((start-pos start-pos) (params '())) (receive (attribute-name pos) (parse-token contents start-pos (char-set #\; #\=)) (if (or (not attribute-name) ;; Still reading params? (not (char=? (string-ref attribute-name 0) #\$))) (values (reverse! params) start-pos) (let ((attrib (http-name->symbol (string-drop attribute-name 1)))) (if (and (< pos (string-length contents)) (char=? (string-ref contents pos) #\=)) (receive (value pos) (parse-token contents (add1 pos) (char-set #\;)) (let ((value (case attrib ((version port) (string->number (or value ""))) ((path) (relative-ref/path-only (or value ""))) (else value)))) (next-param (add1 pos) (cons (cons attrib value) params)))) ;; Missing value is interpreted as "present", so #t (next-param (add1 pos) (cons (cons attrib #t) params)))))))) (receive (global-params pos) (read-params 0) (let loop ((cookies '()) (pos pos)) (let*-values (((name pos) (parse-token contents pos (char-set #\= #\;))) ((val pos) (parse-token contents (add1 pos) (char-set #\;)))) (if (or (not name) (not val)) (reverse! cookies) (receive (local-params pos) (read-params (add1 pos)) (loop (cons (vector (cons name val) (append! local-params global-params)) cookies) (add1 pos)))))))) ;;; Unparsers ;;; (define (unparse-params params unparsers #!key (separator "; ") (grammar 'prefix) (keyword-unparser ->string) (value-unparser unparse-token)) (let loop ((params params) (results '())) (if (null? params) (string-join (reverse results) separator grammar) (let* ((name (caar params)) (val (cdar params)) (str (case val ;; #t means param is present (no value) ((#t) (keyword-unparser name)) ;; #f means param is missing ((#f) #f) (else (let ((unparser (alist-ref name unparsers eq? identity))) (sprintf "~A=~A" (keyword-unparser name) (value-unparser (unparser val)))))))) (loop (cdr params) (if str (cons str results) results)))))) (define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\")) (define quote-string (let ((smap (map (lambda (c) (cons (string c) (string-append "\\" (string c)))) (char-set->list must-be-quoted-chars)))) (lambda (string) (let ((error-chars (char-set #\newline))) (if (string-any error-chars string) (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header" 'unencoded-header 'value string) (string-append "\"" (string-translate* string smap) "\"")))))) ;; Unparse a value as token, converting it to a string first (define (unparse-token token #!optional (separator-chars (char-set #\= #\; #\,))) (let ((trigger-quoting-chars (char-set-union must-be-quoted-chars separator-chars char-set:blank)) (token-string (->string token))) (if (string-any trigger-quoting-chars token-string) (quote-string token-string) token-string))) (define (unparse-etag etag) (string-append (if (eq? 'weak (car etag)) "W/" "") (quote-string (cdr etag)))) ;; Etags are _always_ quoted ;; There's no need to make a specific header unparser for every header type. ;; Usually, the Scheme value representing a header can unambiguously be ;; unparsed into a header just by checking its type. (define (default-header-unparser header-contents) (let loop ((headers (reverse header-contents)) (result '())) (if (null? headers) (list (string-join result ", ")) (let* ((contents (get-value (car headers))) (value (cond ((pair? contents) ; alist? (let ((attribute (symbol->http-name (car contents)))) (if (eq? (cdr contents) #t) (unparse-token attribute) (sprintf "~A=~A" attribute (unparse-token (cdr contents)))))) ((uri-reference? contents) (unparse-token (uri->string contents) (char-set))) (else (unparse-token contents)))) (parameter-unparsers '())) ; Maybe we want to make this a param (loop (cdr headers) (cons (string-append value (unparse-params (get-params (car headers)) parameter-unparsers)) result)))))) (define (etag-unparser header-contents) (list (unparse-etag (get-value (car header-contents))))) (define (if-match-unparser header-contents) (let loop ((headers (reverse header-contents)) (result '())) (cond ((null? headers) (list (string-join result ", "))) ((eq? '* (get-value (car headers))) '("*")) ;; We're done. * means anything (else (loop (cdr headers) (cons (unparse-etag (get-value (car headers))) result)))))) (define (host/port-unparser header-contents) (let ((contents (get-value (car header-contents)))) ;; XXX: urlencode? (if (cdr contents) (list (conc (car contents) ":" (cdr contents))) (list (car contents))))) ;; Handled specially because cookie value is not an alist but a cons of strings (define (set-cookie-unparser header-contents) (let loop ((headers (reverse header-contents)) (result '())) (if (null? headers) result (let* ((unparsed-params (map (lambda (p) (if (eq? (cdr p) #t) (unparse-token (symbol->http-name (car p))) (sprintf "~A=~A" (unparse-token (symbol->http-name (car p))) (cond ((and (eq? (car p) 'port) (pair? (cdr p))) (string-join (map number->string (cdr p)) ",")) ((and (eq? (car p) 'path) (cdr p)) (uri->string (cdr p))) ((eq? (car p) 'expires) (let-locale ((LC_TIME "POSIX")) (time->string (cdr p) "%A, %d-%b-%y %X GMT"))) (else (unparse-token (cdr p))))))) ;; Remove #f values (filter (lambda (p) (cdr p)) (get-params (car headers))))) (cookie (get-value (car headers))) (unparsed-cookie (sprintf "~A=~A" (car cookie) (unparse-token (cdr cookie))))) (loop (cdr headers) (cons (string-join (cons unparsed-cookie unparsed-params) "; ") result)))))) (define (cookie-unparser header-contents) (let loop ((prefix "") (headers (reverse header-contents)) (result '())) (if (null? headers) (list (conc prefix (string-join result "; "))) (let* ((version (get-param 'version (car headers) #f)) (params (alist-delete 'version (get-params (car headers)))) (unparsed-params (map (lambda (p) (if (eq? (cdr p) #t) (unparse-token (conc "$" (symbol->http-name (car p)))) (sprintf "~A=~A" (unparse-token (conc "$" (symbol->http-name (car p)))) (cond ((and (eq? (car p) 'port) (pair? (cdr p))) (string-join (map number->string (cdr p)) ",")) ((and (eq? (car p) 'path) (cdr p)) (uri->string (cdr p))) (else (unparse-token (cdr p))))))) ;; Remove #f values (filter (lambda (p) (cdr p)) params))) (cookie (get-value (car headers))) (unparsed-cookie (sprintf "~A=~A" (car cookie) (unparse-token (cdr cookie))))) ;; Doing it like this means we can't unparse cookies of ;; mixed versions... (loop (if version (sprintf "$Version: ~A; " version) prefix) (cdr headers) (cons (string-join (cons unparsed-cookie unparsed-params) "; ") result)))))) (define (product-unparser header-contents) (list (string-join (map (lambda (content) (conc (first content) (if (second content) (conc "/" (second content)) "") (if (third content) (conc " (" (third content) ")") ""))) (get-value (car header-contents)))))) (define (rfc1123-unparser header-contents) (list (let-locale ((LC_TIME "POSIX")) (time->string (get-value (car header-contents)) "%a, %d %b %Y %X GMT")))) (define (authorization-unparser header-contents) (let loop ((headers (reverse header-contents)) (result '())) (if (null? headers) result (let ((contents (case (get-value (car headers)) ((basic) (let ((user (get-param 'username (car headers))) (pass (get-param 'password (car headers)))) (if (string-index user #\:) (signal-http-condition "Colon detected in username. This is not supported by basic auth!" 'username-with-colon 'value user) (sprintf "Basic ~A" (base64-encode (sprintf "~A:~A" user pass)))))) ((digest) (sprintf "~A ~A" (symbol->http-name (get-value (car headers))) (unparse-params (get-params (car headers)) `((nc . ,identity) ;; see below (uri . ,uri->string) (qop . ,symbol->string) (algorithm . ,symbol->string)) separator: ", " grammar: 'infix keyword-unparser: symbol->string value-unparser: ;; Nasty exception for "nc", an ;; an unquoted padded integer... (lambda (x) (if (number? x) (string-pad (number->string x 16) 8 #\0) (quote-string (->string x))))))) (else (sprintf "~A ~A" (symbol->http-name (get-value (car headers))) (unparse-params (get-params (car headers)) '())))))) (loop (cdr headers) (cons contents result)))))) (define (authenticate-unparser header-contents) (let loop ((headers (reverse header-contents)) (result '())) (if (null? headers) result (let ((contents (sprintf "~A ~A" (symbol->http-name (get-value (car headers))) (let* ((old (get-params (car headers))) ;; A quick hack to get presence of "stale" ;; coded as TRUE instead of value-less param ;; false value is coded by its absense (params (if (alist-ref 'stale old) (alist-update! 'stale 'TRUE old) (alist-delete 'stale old)))) (unparse-params params `((domain . ,(lambda (u) (string-join (map uri->string u)))) (qop . ,(lambda (q) (string-join (map symbol->string q) ","))) (algorithm . ,symbol->string)) separator: ", " grammar: 'infix keyword-unparser: symbol->string value-unparser: (lambda (x) (if (eq? x 'TRUE) "TRUE" (quote-string (->string x))))))))) (loop (cdr headers) (cons contents result))))))