diff options
Diffstat (limited to 'header-parsers.scm')
| -rw-r--r-- | header-parsers.scm | 994 |
1 files changed, 994 insertions, 0 deletions
diff --git a/header-parsers.scm b/header-parsers.scm new file mode 100644 index 0000000..89edeae --- /dev/null +++ b/header-parsers.scm @@ -0,0 +1,994 @@ +;;;; 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 <locale.h>") + +(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 <start>-<end>/<total> +(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/]<string> +;; 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))))))))) + +;; ( <product>[/<version>] [<comment>] )+ +;; 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)) |