;;;; Header value accessor procedures ;; Get the raw contents of a header (define (header-contents name headers #!optional default) (cond ((assq name (headers-v headers)) => cdr) (else 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) (let ((params (header-params header-name headers))) (cond ((not (pair? params)) default) ((assq param-name params) => cdr) (else default)))) ;; Get the value from one header entry (define get-value (cut vector-ref <> 0)) ;; Fast local version (define-compiler-syntax get-value (syntax-rules () ((_ header-entry) (vector-ref header-entry 0)))) ;; Get all params from one header entry (define get-params (cut vector-ref <> 1)) ;; Fast local version (define-compiler-syntax get-params (syntax-rules () ((_ header-entry) (vector-ref header-entry 1)))) ;; Get one specific parameter from one header entry (define (get-param param contents #!optional (default #f)) (let ((params (vector-ref contents 1))) (cond ((not (pair? params)) default) ((assq param params) => cdr) (else default)))) (define (get-no-newline-value header) (let ((v (get-value header))) (when (string-index v #\newline) ;; There's duplication with quote-string error here... (signal-http-condition 'raw-value (conc "Unencoded newline in header contents! " "Please encode the newline in a way " "appropriate for this header") (list string) 'unencoded-header 'value string)) v)) ;;;; 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 #!optional (stop-char-set (char-set-adjoin char-set:whitespace #\,))) (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 value char-set:whitespace 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 value char-set:whitespace 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 value char-set:whitespace 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 (cond ((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)))) ((char=? #\" (string-ref value pos)) (let lp ((end (add1 pos)) (c (string-ref value (add1 pos))) (res '())) (cond ((char=? #\" c) (loop (string-append result (reverse-list->string res)) (add1 end))) ((char=? #\\ c) (lp (+ end 2) (string-ref value (+ end 2)) (cons (string-ref value (add1 end)) res))) (else (lp (add1 end) (string-ref value (add1 end)) (cons c res)))))) ;; Else it's a ) (else (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-params string start-pos param-subparsers #!optional (stop-set (char-set #\;)) (separator-or-stop-set (char-set #\; #\=))) (let loop ((start-pos start-pos) (params '())) (unless separator-or-stop-set (error "The parse-params API has changed a bit for performance reasons: if you pass the optional stop char set, you need to pass one more argument which is the same char-set extended with an equals-sign")) (receive (attribute-name pos) (parse-token string start-pos separator-or-stop-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+params 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-params 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+params entry 0 value-subparser parameter-subparsers) type+params))) (define (make-key/value-subparser key/value-subparsers) (lambda (k/v) ;; We're abusing parse-params here to read value ;; instead of params. This is weird, but it works :) (receive (key+value pos) (parse-params 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 ((date-regex (irregex (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 (irregex-match date-regex str) ; Or irregex-search? (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)) ;; RFC 1123 updates RFC 822's datetime spec (define (rfc1123-subparser str) (or (rfc1123-string->time str) (signal-http-condition 'rfc1123-subparser "Error parsing RFC 1123 date/time" (list str) 'rfc1123-subparser 'value str))) (define (rfc850-subparser str) (or (rfc850-string->time str) (signal-http-condition 'rfc850-subparser "Error parsing RFC850 date/time" (list str) 'rfc850-subparser 'value str))) (define (asctime-subparser str) (or (asctime-string->time str) (signal-http-condition 'asctime-subparser "Error parsing asctime() date/time" (list str) 'asctime-subparser 'value str))) ;; rfc1123-date | rfc850-date | asctime-date (define (http-date-subparser str) (or (http-date-string->time str) (signal-http-condition 'http-date-subparser "Error parsing date/time" (list str) '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. ;; It also will ensure that the value is raw, (define (unknown-header-parser contents) (list (vector contents 'raw))) (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) ;; This is retarded. The websocket spec (RFC6455) explicitly says the ;; product token must be compared case-insensitively. RFC2817, ;; "upgrading to TLS within HTTP/1.1" doesn't mention anything about ;; case sensitivity, but defines an all-uppercase token. This means ;; that there're going to be servers which accept only "TLS/1.0" ;; as-is. This all just means we can't add the convenience of ;; downcasing and switching to a symbol, pushing the case-(in)sensitive ;; comparison down the the user level, causing more bugs :( (define (product-subparser contents) (let* ((idx (string-index contents #\/)) (version (and idx (substring/shared contents (add1 idx))))) (if (and idx version) (cons (substring/shared contents 0 idx) version) (cons contents #f)))) ;; bytes -/ (define range-subparser (let ((range-regex (irregex '(seq "bytes" (+ space) (=> start (+ digit)) "-" (=> end (+ digit)) "/" (=> total (+ digit)))))) (lambda (s) (and-let* ((m (irregex-match range-regex s)) (start (string->number (irregex-match-substring m 'start))) (end (string->number (irregex-match-substring m 'end))) (total (string->number (irregex-match-substring m 'total)))) (list start end total))))) ;; Accept *just* a filename, not a full path (simply strips directories) ;; This matches the content-disposition recommendation in RFC2616, 19.5.1: ;; "The receiving user agent SHOULD NOT respect any directory path ;; information present in the filename-parm parameter, which is the only ;; parameter believed to apply to HTTP implementations at this time. The ;; filename SHOULD be treated as a terminal component only." ;; This echoes RFC2183 (and RFC1806 which it supersedes), section 2.3: ;; "The receiving MUA SHOULD NOT respect any directory path information ;; that may seem to be present in the filename parameter. The filename ;; should be treated as a terminal component only." (define (filename-subparser fn) (let ((base-fn (pathname-strip-directory (string-trim-both fn)))) (and (not (member base-fn '("" "." ".."))) (not (string-index base-fn (char-set #\/ #\nul))) base-fn))) ;; [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 software-parser (let ((char-set:space-or-paren (char-set-union (char-set #\() char-set:whitespace)) (char-set:slash-or-paren (char-set #\/ #\())) (lambda (contents) (let loop ((start-pos 0) (products '())) (let*-values (((product pos) (parse-token contents start-pos char-set:slash-or-paren)) ((version pos2) (parse-token contents pos ; (add1 pos) char-set:space-or-paren)) ((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 (multiple identity)) ;; 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? (let ((old-cookie-regex (irregex '(seq bos (+ (~ #\= #\")) "=" (* (~ #\;)) ";" ; (* any) (w/nocase "expires") (* space) "=")))) (lambda (cookie) (irregex-search old-cookie-regex 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 rfc1123-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 (strict-transport-security-parser contents) ;; This is ridiculous; there are no parameters because everything ;; is a parameter (or everything is a value, depending on your point ;; of view). The header has no main value. For convenience and sanity ;; we just return an alist as a single value. (list (vector (parse-params contents 0 `((max-age . ,natnum-subparser))) '()))) (define (basic-auth-param-subparser contents pos) (receive (secret pos) (parse-token contents 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)))) (values `((username . ,user) (password . ,pass)) pos)))) (define (digest-auth-param-subparser contents pos) (parse-params contents pos `((nc . ,(lambda (n) (string->number n 16))) (uri . ,uri-reference) (qop . ,symbol-subparser) (algorithm . ,symbol-subparser-ci)) (char-set #\,) (char-set #\, #\=))) (define authorization-param-subparsers (make-parameter `((basic . ,basic-auth-param-subparser) (digest . ,digest-auth-param-subparser)))) (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)) (default-subparser (lambda (contents pos) (parse-params contents pos '())))) (receive (params pos) ((alist-ref authtype (authorization-param-subparsers) eq? default-subparser) 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-params 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 #\,) (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-params 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 (assq name unparsers)) (unparsed-val (if unparser ((cdr unparser) val) val))) (string-append (keyword-unparser name) "=" (value-unparser unparsed-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 string) (reverse-list->string (cons #\" (string-fold (lambda (c result) (cond ((char=? c #\newline) (signal-http-condition 'quote-string (conc "Unencoded newline in header contents! " "Please encode the newline in a way " "appropriate for this header") (list string) 'unencoded-header 'value string)) ((char-set-contains? must-be-quoted-chars c) (cons c (cons #\\ result))) (else (cons c result)))) '(#\") string)))) ;; Unparse a value as token, converting it to a string first (define unparse-token (let ((default-trigger-chars (char-set-union must-be-quoted-chars (char-set #\= #\; #\,) char-set:blank))) (lambda (token #!optional separator-chars) (let ((trigger-quoting-chars (if separator-chars (char-set-union must-be-quoted-chars separator-chars char-set:blank) default-trigger-chars)) (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* ((header (car headers)) (contents (get-value header)) (value (cond ((pair? contents) ; alist? (let ((attribute (symbol->http-name (car contents)))) (if (eq? (cdr contents) #t) (unparse-token attribute) (string-append attribute "=" (unparse-token (cdr contents)))))) ((uri-reference? contents) (unparse-token (uri->string contents) (char-set))) (else (unparse-token contents))))) (loop (cdr headers) (cons (string-append value (unparse-params (get-params header) '())) result)))))) ;; RFC2616 19.5.1 says that the "filename" attribute _must_ be quoted. ;; It's a bit annoying that our API currently can't specify for particular ;; attributes that only those must be unparsed specially, so we quote _all_ ;; attributes (which, strictly speaking, is always allowed for tokens) unless ;; otherwise specified by a hack (when the value is prefixed by RAW). ;; This may be dangerous or wrong, if a server doesn't accept quoted "name" ;; attributes, for example. Not too likely since names can contain spaces etc. (define (content-disposition-unparser header-contents) (let* ((type (get-value (car header-contents))) (RAW (list 'raw)) (unparser (lambda (x) (if (and (pair? x) (eq? RAW (car x))) (cdr x) (quote-string (->string x)))))) (list (conc (unparse-token type) (unparse-params (get-params (car header-contents)) `((filename . ,pathname-strip-directory) (size . ,(lambda (x) (cons RAW (number->string x)))) (creation-date . ,rfc1123-time->string) (modification-date . ,rfc1123-time->string) (read-date . ,rfc1123-time->string)) value-unparser: unparser))))) (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) (map (lambda (header) (let* ((unparsed-params (map (lambda (p) (if (eq? (cdr p) #t) (unparse-token (symbol->http-name (car p))) (string-append (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 header)))) (cookie (get-value header)) (unparsed-cookie (string-append (car cookie) "=" (unparse-token (cdr cookie))))) (string-join (cons unparsed-cookie unparsed-params) "; "))) header-contents)) (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)))) (string-append (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 (string-append (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 (software-unparser header-contents) (list (string-join (map (lambda (content) (conc (unparse-token (first content)) (if (second content) (conc "/" (unparse-token (second content))) "") (if (third content) (conc " (" (third content) ")") ""))) (get-value (car header-contents)))))) (define (product-unparser header-contents) (list (string-join (map (lambda (header) (let* ((default-unparser ; Not great, but better than nothing (lambda (params) (unparse-params params '()))) (product+version (get-value header))) (conc (unparse-token (car product+version)) (if (cdr product+version) (conc "/" (unparse-token (cdr product+version))) "")))) header-contents) ", "))) (define (via-unparser header-contents) (list (string-join (map get-value header-contents) ", "))) (define (rfc1123-unparser header-contents) (list (rfc1123-time->string (get-value (car header-contents))))) (define-constant short-weekdays `#("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) (define-constant short-months `#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) (define (rfc1123-time->string time) (let ((padded (lambda (n) (if (fx< n 10) (string-append "0" (number->string n)) (number->string n)))) (secs (vector-ref time 0)) (mins (vector-ref time 1)) (hours (vector-ref time 2)) (mday (vector-ref time 3)) (month (vector-ref time 4)) (year (vector-ref time 5)) (wday (vector-ref time 6))) (string-append (vector-ref short-weekdays wday) ", " (padded mday) " " (vector-ref short-months month) " " (number->string (+ 1900 year)) " " (padded hours) ":" (padded mins) ":" (padded secs) " GMT"))) (define (basic-auth-param-subunparser params) (let ((user (alist-ref 'username params)) (pass (alist-ref 'password params))) (if (string-index user #\:) (signal-http-condition 'basic-auth-param-subunparser "Colon detected in username. This is not supported by basic auth!" (list user) 'username-with-colon 'value user) (base64-encode (string-append user ":" pass))))) (define (digest-auth-param-subunparser params) (unparse-params params `((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", which is an unquoted ;; padded integer... (lambda (x) (if (number? x) (string-pad (number->string x 16) 8 #\0) (quote-string (->string x)))))) (define authorization-param-subunparsers (make-parameter `((basic . ,basic-auth-param-subunparser) (digest . ,digest-auth-param-subunparser)))) (define (authorization-unparser header-contents) (map (lambda (header) (let* ((default-unparser ; Not great, but better than nothing (lambda (params) (unparse-params params '()))) (auth-scheme (get-value header)) (unparser (alist-ref auth-scheme (authorization-param-subunparsers) eq? default-unparser))) (string-append (symbol->http-name auth-scheme) " " (->string (unparser (get-params header)))))) header-contents)) (define (authenticate-unparser header-contents) (map (lambda (header) (string-append (symbol->http-name (get-value header)) " " (let* ((old (get-params header)) ;; 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)))))))) header-contents)) (define (strict-transport-security-unparser header-contents) (map (lambda (header) ; Should only be one header; the rest must be ignored! (unparse-params (get-value header) '() grammar: 'infix keyword-unparser: ; Ugly but neccessary (lambda (k) (if (eq? k 'includesubdomains) "includeSubDomains" (->string k))))) header-contents))