summaryrefslogtreecommitdiff
path: root/header-parsers.scm
diff options
context:
space:
mode:
Diffstat (limited to 'header-parsers.scm')
-rw-r--r--header-parsers.scm994
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))