source: project/release/4/intarweb/trunk/header-parsers.scm @ 16157

Last change on this file since 16157 was 16157, checked in by sjamaan, 10 years ago

Add some nasty hackage to get www-authenticate output like it is supposed to be... (which is inconsistent with nearly all of the rest of HTTP, even though that's internally inconsistent itself... GRAAHHH!)

File size: 33.7 KB
Line 
1;;;; Header value accessor procedures
2
3;; Get the raw contents of a header
4(define (header-contents name headers #!optional default)
5  (alist-ref name (headers-v headers) eq? default))
6
7;; Get all values of a header
8(define (header-values header-name headers)
9  (map (cut vector-ref <> 0) (header-contents header-name headers '())))
10
11;; Get the value of a header, assuming it has only one value
12(define (header-value header-name headers #!optional default)
13  (let ((contents (header-contents header-name headers '())))
14    (if (null? contents)
15        default
16        (get-value (car contents)))))
17
18;; Get the parameters of a header, assuming it has only one value
19(define (header-params header-name headers)
20  (let ((contents (header-contents header-name headers '())))
21    (if (null? contents)
22        '()
23        (get-params (car contents)))))
24
25;; Get a specific parameter of a header, assuming it has only one value
26(define (header-param param-name header-name headers #!optional default)
27  (alist-ref param-name (header-params header-name headers) eq? default))
28
29;; Get the value from one header entry
30(define get-value (cut vector-ref <> 0))
31
32;; Get all params from one header entry
33(define get-params (cut vector-ref <> 1))
34
35;; Get one specific parameter from one header entry
36(define (get-param param contents #!optional (default #f))
37  (alist-ref param (vector-ref contents 1) eq? default))
38
39;;;; Header parsers
40
41(define (single subparser #!optional (parameter-subparsers '()))
42  (lambda (contents)
43    (list ((with-params subparser parameter-subparsers) contents))))
44
45(define (multiple subparser #!optional (parameter-subparsers '()))
46  (lambda (contents)
47    (map (with-params subparser parameter-subparsers)
48         (split-multi-header contents))))
49
50;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
51(define (split-multi-header value)
52  (let ((len (string-length value)))
53    (let loop ((result '())
54               (start-pos 0)   ; Where the current header value starts
55               (search-pos 0)) ; Where the searching starts
56      (or (and-let* (((< search-pos len))
57                     (pos (string-index value (char-set #\, #\") search-pos)))
58            (if (char=? #\, (string-ref value pos))
59                (loop (cons (string-copy value start-pos pos) result) (add1 pos) (add1 pos))
60                (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\"))))
61                  (loop result start-pos (add1 end-pos)))))
62          (reverse (cons (string-drop value start-pos) result))))))
63
64;; Remove all escape characters from the input, recognising "escaped escapes"
65(define (unescape str)
66  (let ((last-char (sub1 (string-length str))))
67    (let loop ((result "")
68               (start-pos 0))
69      (or (and-let* ((pos (string-index str #\\ start-pos)))
70            (if (= pos last-char)
71                (string-append result (string-copy str start-pos))
72                (loop (string-append result (string-copy str start-pos pos)
73                                     (string-copy str (add1 pos) (+ pos 2)))
74                      (+ pos 2))))
75          (string-append result (string-copy str start-pos))))))
76
77;; Find a matching endpoint for a token, ignoring escaped copies of the token
78(define (escaped-string-end str start stop-char-set)
79  (let ((len (string-length str)))
80    (let loop ((start start))
81      (let ((pos (string-index str (char-set-adjoin stop-char-set #\\) start)))
82        (if pos
83            (if (char=? #\\ (string-ref str pos))
84                ;; Escaped matching closing symbol
85                (if (= len (add1 pos))
86                    pos
87                    (loop (+ pos 2)))
88                ;; Reached the matching closing symbol
89                pos)
90            len))))) ; No matching closing symbol?  "Insert" it at the end
91
92;; Try to parse a token, starting at the provided offset, up until the
93;; char-set where we should stop.  Returns two values: the token or #f if
94;; there is no token left, and the position on which the token ends.
95(define (parse-token value start-pos stop-char-set)
96  (if (>= start-pos (string-length value))
97      (values #f start-pos)
98      (let ((stop (char-set-adjoin stop-char-set #\")))
99        (let ((pos (string-index value stop start-pos)))
100          (if pos
101              (if (not (char=? #\" (string-ref value pos)))
102                  (values (string-trim-both (string-copy value start-pos pos))
103                          pos) ; Stop-char found, but no quoting
104                  (let ((end-pos (escaped-string-end value (add1 pos)
105                                                     (char-set #\"))))
106                    ;; Found the double quote? Recurse on the remainder
107                    (receive (rest final-pos)
108                      (parse-token value (add1 end-pos) stop-char-set)
109                      (values (string-append
110                               (string-trim-both
111                                (string-copy value start-pos pos))
112                               (if (= pos end-pos)
113                                   (unescape (string-copy value (add1 pos)))
114                                   (unescape (string-copy value (add1 pos) end-pos)))
115                               (or rest ""))
116                              final-pos))))
117              ;; Nothing found?  Then the remainder of the string is the token
118              (values (string-trim-both (string-copy value start-pos))
119                      (string-length value)))))))
120
121;; Comments are a bit like tokens, except they can be nested
122(define (parse-comment value start-pos)
123  (let* ((len (string-length value))
124         (nospace-pos (and (< start-pos len)
125                           (string-skip value char-set:whitespace start-pos))))
126    (if (and nospace-pos (char=? (string-ref value nospace-pos) #\())
127        (let loop ((result "")
128                   (start-pos (add1 nospace-pos)))
129          (if (>= start-pos len)
130              (values result len)
131              (let ((pos (string-index value (char-set #\( #\)) start-pos)))
132                (if pos
133                    (if (char=? #\( (string-ref value pos)) ; Nested comment
134                        (receive (nested end-pos)
135                          (parse-comment value pos)
136                          (loop (sprintf "~A~A(~A)"
137                                         result
138                                         (string-copy value start-pos pos)
139                                         nested)
140                                (add1 end-pos)))
141                        ;; Else it's a )
142                        (values (conc result (string-copy value start-pos pos)) (add1 pos)))
143                    ;; Nothing found?  Then the remainder of the string is the token
144                    (values (conc result (string-copy value start-pos))
145                            (string-length value))))))
146        ;; No (? Then fail to match the 'comment'
147        (values #f start-pos))))
148
149(define (parse-parameters string start-pos param-subparsers #!optional (stop-set (char-set #\;)))
150  (let loop ((start-pos start-pos)
151             (params '()))
152    (receive (attribute-name pos)
153      (parse-token string start-pos (char-set-union stop-set (char-set #\=)))
154      (if attribute-name
155          (let ((attribute (http-name->symbol attribute-name)))
156            (if (and (< pos (string-length string))
157                     (char=? (string-ref string pos) #\=))
158                (receive (value pos)
159                  (parse-token string (add1 pos) stop-set)
160                  ;; In case of no value ("foo="), use the empty string as value
161                  (let ((value ((alist-ref attribute param-subparsers
162                                           eq? identity)
163                                (or value ""))))
164                    (loop (add1 pos) (cons (cons attribute value) params))))
165                ;; Missing value is interpreted as "present",
166                ;; so #t. If not present, it's #f when looking it up
167                (loop (add1 pos) (cons (cons attribute #t) params))))
168          (values (reverse params) pos)))))
169
170(define (parse-value+parameters string start-pos
171                                value-subparser param-subparsers)
172  (receive (value pos)
173    (parse-token string start-pos (char-set #\;))
174    (if (not value)
175        (values #f pos) ;; XXX this is wrong and not expected by the caller!
176        (receive (params pos)
177          (parse-parameters string (add1 pos) param-subparsers)
178          (values (vector (value-subparser value) params) pos)))))
179
180(define (with-params value-subparser parameter-subparsers)
181  (lambda (entry)
182    (receive (type+params pos)
183      (parse-value+parameters entry 0 value-subparser parameter-subparsers)
184      type+params)))
185
186(define (make-key/value-subparser key/value-subparsers)
187  (lambda (k/v)
188    ;; We're abusing parse-parameters here to read value
189    ;; instead of params.  This is weird, but it works :)
190    (receive (key+value pos)
191      (parse-parameters k/v 0 key/value-subparsers)
192      (vector (car key+value) '())))) ;; There's only one key/value pair
193
194(foreign-declare "#include <locale.h>")
195
196(define-foreign-variable LC_TIME int)
197
198(define setlocale (foreign-lambda c-string setlocale int c-string))
199
200(define-syntax let-locale
201  (syntax-rules ()
202    ((let-locale ((cat val) ...) body ...)
203     (let ((backup '()))
204       (dynamic-wind
205           (lambda () (set! backup `((cat . ,(setlocale cat val)) ...)))
206           (lambda () body ...)
207           (lambda () (setlocale cat (alist-ref 'cat backup)) ...))))))
208
209(define (make-date->string-parser spec)
210  (let ((regex
211         (string-translate*
212          spec
213          '((" "  . " +")    ; Any number of spaces is very permissive
214            ("%a" . "(Sun|Mon|Tue|Wed|Thu|Fri|Sat)")
215            ("%A" . "(Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday)")
216            ("%d" . "[0-9]{1,2}")
217            ("%b" . "(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)")
218            ("%y" . "[0-9]{1,2}")
219            ("%Y" . "[0-9]{4}")
220            ("%X" . "[0-9]{2}:[0-9]{2}:[0-9]{2}")))))
221    (lambda (str)
222      (and (string-search regex str)
223           (let-locale ((LC_TIME "POSIX"))
224                       (string->time str spec))))))
225
226(define rfc1123-string->time (make-date->string-parser "%a, %d %b %Y %X GMT"))
227
228;; This is a little more relaxed than strict rfc850 (it allows abbreviated
229;; weekdays) - for example Google Web Server outputs cookies in this format.
230(define rfc850-string->time
231  (disjoin (make-date->string-parser "%A, %d-%b-%y %X GMT")
232           (make-date->string-parser "%a, %d-%b-%Y %X GMT")))
233
234(define asctime-string->time (make-date->string-parser "%a %b %d %X %Y"))
235
236(define http-date-string->time
237  (disjoin rfc1123-string->time rfc850-string->time asctime-string->time))
238
239(define (rfc1123-subparser str)
240  (or (rfc1123-string->time str)
241      (signal-http-condition "Error parsing RFC 1123 date/time"
242                             'rfc1123-subparser 'value str)))
243
244(define (rfc850-subparser str)
245  (or (rfc850-string->time str)
246      (signal-http-condition "Error parsing RFC850 date/time"
247                             'rfc850-subparser 'value str)))
248
249(define (asctime-subparser str)
250  (or (asctime-string->time str)
251      (signal-http-condition "Error parsing asctime() date/time"
252                             'asctime-subparser 'value str)))
253
254;; rfc1123-date | rfc850-date | asctime-date
255(define (http-date-subparser str)
256  (or (http-date-string->time str)
257      (signal-http-condition "Error parsing date/time"
258                             'http-date-subparser 'value str)))
259
260;; Change the accuracy of a number to 'digits' number of digits to the
261;; right of the decimal point.
262(define (chop-number num digits)
263  (let ((factor (expt 10 digits)))
264    (/ (round (* num factor)) factor)))
265
266(define (quality-subparser str)
267  ;; Anything that's not a number is seen as if the value is missing, hence 1.0
268  (let* ((num       (or (string->number str) 1.0))
269         (imprecise (chop-number num 3)))
270    (max 0.0 (min 1.0 imprecise))))
271
272;; Just put all header strings in a list, so we can pass it on
273;; Make no assumptions about the contents (only value, don't try to parse params)
274;; This is different from (multiple (without-params generic-header-parser))
275;; because this does not assume it can split up comma-separated values
276(define (unknown-header-parser contents)
277  (list (vector contents '())))
278
279(define symbol-subparser
280  (compose string->symbol string-trim-both))
281
282(define symbol-subparser-ci
283  (compose string->symbol string-trim-both string-downcase))
284
285(define (natnum-subparser contents)
286  (let ((num (string->number contents)))
287    (if num (inexact->exact (max 0 (round num))) 0)))
288
289(define (host/port-subparser contents)
290  (let ((idx (string-index-right contents #\:)))
291    (if idx
292        (cons (substring/shared contents 0 idx)
293              (inexact->exact
294               (round (or (string->number (substring/shared contents (add1 idx)))
295                          80))))
296        (cons contents 80))))
297
298; base64 of 128 bit hex digest as per RFC1864 (eg, Content-md5)
299(define base64-subparser base64-decode)
300
301;; bytes <start>-<end>/<total>
302(define (range-subparser s)
303  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
304            (map string->number (drop parts 1))))
305
306;; [W/]<string>
307;; This is a full parser, because it needs to be able to distinguish
308;; between W/"foo" and "W/foo". If it's preprocessed by the tokenizer
309;; both get "normalised" to the same thing: W/foo
310;;
311;; XXX It could be a good idea if the single/multiple token parsers
312;; did not do anything to their contents.  If the consuming parsers
313;; want tokens, they know how to have it. OTOH, it would mean much
314;; more code for all the parsers as they need to tokenize more...
315(define (entity-tag-parser contents)
316  (let ((contents (string-trim-both contents)))
317    (list (vector
318           (if (string-prefix? "W/" contents)
319               `(weak . ,(parse-token contents 2 char-set:whitespace))
320               `(strong . ,(parse-token contents 0 char-set:whitespace)))
321           '()))))
322
323;; Used for both if-match and if-none-match
324;; This is either a wilcard ('*') or several entities
325(define (if-match-parser contents)
326  (let ((contents (string-trim-both contents)))
327    (if (string=? "*" contents)
328        (list (vector '* '()))
329        (let loop ((pos 0)
330                   (etags '()))
331          (let ((weak (string-prefix? "W/" contents 0 2 pos)))
332            (receive (etag newpos)
333              (parse-token contents (+ pos (if weak 2 0)) char-set:whitespace)
334              (let ((newpos (string-skip contents char-set:whitespace newpos))
335                    (value (and etag (vector (cons (if weak 'weak 'strong)
336                                                   etag) '()))))
337               (if value
338                   (if newpos
339                       (loop newpos (cons value etags))
340                       (reverse! (cons value etags)))
341                   (reverse! etags)))))))))
342
343;; ( <product>[/<version>] [<comment>] )+
344;; This parser is a full parser because parse-token cannot handle
345;; comments yet... (if a ; is in a comment, it breaks down)
346(define (product-parser contents)
347  (let loop ((start-pos 0)
348             (products '()))
349    (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\()))
350                  ((version pos2) (parse-token contents pos ; (add1 pos)
351                                               (char-set-union (char-set #\()
352                                                               char-set:whitespace)))
353                  ((comment pos3) (parse-comment contents pos2))
354                  ;; Ugh
355                  ((real-version) (and version (not (string-null? version)) (string-trim version #\/))))
356      (if product
357          (loop pos3 (cons (list product real-version comment) products))
358          (list (vector (reverse products) '()))))))
359
360;;;; MAJOR TODOs
361;; RFC1123 mailbox parser - just strings for now
362(define mailbox-subparser identity)
363
364;; Either an entity-tag or a http-date
365(define (if-range-parser contents)
366  (let ((http-date ((with-params http-date-string->time '()) contents)))
367    (if (get-value http-date)
368        (list http-date)
369        (entity-tag-parser contents))))
370
371;; Either delta-seconds or http-date
372(define retry-after-subparser (disjoin http-date-subparser natnum-subparser))
373
374;; Tricky - see 2616 14.45
375;; We probably shouldn't try to do too much parsing here
376(define via-parser split-multi-header)
377
378;; Tricky - see 2616 14.46
379(define warning-parser split-multi-header)
380;;;; END MAJOR TODOs
381
382(define (key/value-subparser str)
383  (let ((idx (string-index str #\=)))
384    (cons (string->symbol (string-take str idx)) (string-drop str (add1 idx)))))
385
386;; The 'expires' header defined by the Netscape cookie spec contains
387;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
388(define (old-style-cookie? cookie)
389  (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))
390
391(define (string->number-list str)
392  (map string->number (string-split str ",")))
393
394;; We're using http-date-subparser for 'expires' instead of rfc850-subparser
395;; (which would be the correct thing to do) because several well-known web
396;; server software packages (tested: PHP and Rails) get it wrong.  So we
397;; will go by the robustness principle and allow any kind of HTTP date.
398(define set-cookie-parser
399  (let ((param-subparsers `((expires . ,http-date-subparser)
400                            (max-age . ,string->number)
401                            (version . ,string->number)
402                            (port    . ,string->number-list))))
403    (lambda (contents)
404      (if (old-style-cookie? contents)
405          (list ((with-params key/value-subparser param-subparsers) contents))
406          (map (with-params key/value-subparser param-subparsers)
407               (split-multi-header contents))))))
408
409(define cache-control-parser
410  (let ((splitter (lambda (str) ;; Is this correct?
411                    (map (compose string->symbol string-trim-both)
412                         (string-split str ",")))))
413    (lambda (contents)
414      (map
415       (make-key/value-subparser `((max-age . ,natnum-subparser)
416                                   (s-maxage . ,natnum-subparser)
417                                   (max-stale . ,natnum-subparser)
418                                   (min-fresh . ,natnum-subparser)
419                                   (private . ,splitter)
420                                   (no-cache . ,splitter)))
421       (split-multi-header contents)))))
422
423(define (authorization-parser contents)
424  (let loop ((pos 0)
425             (result '()))
426    (receive (authtype pos)
427      (parse-token contents pos char-set:whitespace)
428      (if (not authtype)
429          (reverse result)
430          (let ((authtype (http-name->symbol authtype)))
431            (case authtype
432              ((basic) (receive (secret pos)
433                         (parse-token contents (add1 pos) (char-set #\,))
434                         (let* ((decoded (base64-decode secret))
435                                (colon-idx (string-index decoded #\:))
436                                (user (string-take decoded colon-idx))
437                                (pass (string-drop decoded (add1 colon-idx))))
438                           (loop (add1 pos)
439                                 (cons (vector authtype
440                                               `((username . ,user)
441                                                 (password . ,pass))) result)))))
442              ((digest) (receive (params pos)
443                          (parse-parameters contents pos
444                                            `((nc . ,(lambda (n)
445                                                       (string->number n 16)))
446                                              (uri . ,uri-reference)
447                                              (qop . ,symbol-subparser)
448                                              (algorithm . ,symbol-subparser-ci))
449                                            (char-set #\,))
450                          (loop (add1 pos)
451                                (cons (vector authtype params) result))))
452              (else (receive (params pos)
453                      (parse-parameters contents (add1 pos) '())
454                      (loop (add1 pos)
455                            (cons (vector authtype params) result))))))))))
456
457(define (authenticate-parser contents)
458  (let loop ((pos 0)
459             (result '()))
460    (receive (authtype pos)
461      (parse-token contents pos char-set:whitespace)
462      (if (not authtype)
463          (reverse result)
464          (let ((authtype (http-name->symbol authtype)))
465            (receive (params pos)
466              (parse-parameters contents pos
467                                `((domain . ,(lambda (s)
468                                               (map uri-reference
469                                                    (string-split s))))
470                                  (qop . ,(lambda (s)
471                                            (map (compose symbol-subparser
472                                                          string-trim)
473                                                 (string-split s ","))))
474                                  (algorithm . ,symbol-subparser-ci)
475                                  (stale . ,(lambda (s)
476                                              (string-ci=? (string-trim s)
477                                                           "TRUE"))))
478                                (char-set #\,))
479              (loop (add1 pos) (cons (vector authtype params) result))))))))
480
481(define (pragma-parser contents)
482  (map (make-key/value-subparser `()) (split-multi-header contents)))
483
484(define (te-parser contents)
485  (map (make-key/value-subparser `((q . ,quality-subparser)))
486       (split-multi-header contents)))
487
488;; Cookie headers are also braindead: there can be several cookies in one header,
489;; separated by either commas or semicolons. The only way to distinguish a
490;; new cookie from a parameter of the current cookie is the dollar in front
491;; of all parameter names.
492;; Also, there's a $Version attribute that prepends all cookies, which is
493;; considered to apply to all cookies that follow.
494;;
495;; This code is a bit of a hack in the way it abuses parse-parameters
496(define (cookie-parser contents)
497  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
498  (define (split-attribs pairs)
499    (span (lambda (pair)
500            (string-prefix? "$" (symbol->string (car pair))))
501          pairs))
502  (receive (params pos)
503    (parse-parameters contents 0 `(($version . ,string->number)
504                                   ($port . ,string->number)))
505    (receive (global-attrs remaining)
506      (split-attribs params)
507      (let loop ((remaining remaining)
508                 (cookies '()))
509        (if (null? remaining)
510            (reverse cookies)
511            (let ((cookie (car remaining))
512                  (params (cdr remaining)))
513              (receive (local-attrs rest)
514                (split-attribs params)
515                (let* ((all-attrs (map
516                                   (lambda (a) ; remove the $
517                                     (cons
518                                      (string->symbol
519                                       (string-drop
520                                        (symbol->string (car a)) 1))
521                                      (cdr a)))
522                                   (append global-attrs local-attrs)))
523                       (result (vector cookie all-attrs)))
524                  (loop rest (cons result cookies))))))))))
525
526;;; Unparsers ;;;
527(define (unparse-params params unparsers #!key
528                        (separator "; ") (grammar 'prefix)
529                        (keyword-unparser symbol->http-name)
530                        (value-unparser unparse-token))
531  (let loop ((params params)
532             (results '()))
533    (if (null? params)
534        (string-join (reverse results) separator grammar)
535        (let* ((name (caar params))
536               (val (cdar params))
537               (str (case val
538                      ;; #t means param is present (no value)
539                      ((#t) (keyword-unparser name))
540                      ;; #f means param is missing
541                      ((#f) #f)
542                      (else (let ((unparser (alist-ref name unparsers
543                                                       eq? identity)))
544                              (sprintf "~A=~A"
545                                       (keyword-unparser name)
546                                       (value-unparser (unparser val))))))))
547          (loop (cdr params) (if str (cons str results) results))))))
548
549(define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
550
551(define quote-string
552  (let ((smap (map (lambda (c)
553                     (cons (string c)
554                           (string-append "\\" (string c))))
555                   (char-set->list must-be-quoted-chars))))
556    (lambda (string)
557      (let ((error-chars (char-set #\newline)))
558        (if (string-any error-chars string)
559            (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
560                                   'unencoded-header 'value string)
561            (string-append "\"" (string-translate* string smap) "\""))))))
562
563;; Unparse a value as token, converting it to a string first
564(define (unparse-token token #!optional (separator-chars (char-set #\= #\; #\,)))
565  (let ((trigger-quoting-chars
566         (char-set-union must-be-quoted-chars separator-chars char-set:blank))
567        (token-string (->string token)))
568    (if (string-any trigger-quoting-chars token-string)
569        (quote-string token-string)
570        token-string)))
571
572;; There's no need to make a specific header unparser for every header type.
573;; Usually, the Scheme value representing a header can unambiguously be
574;; unparsed into a header just by checking its type.
575(define (default-header-unparser header-name header-contents)
576  (let loop ((headers (reverse header-contents))
577             (result '()))
578    (if (null? headers)
579        (string-join result ", ")
580        (let* ((contents (get-value (car headers)))
581               (value (cond
582                       ((pair? contents) ; alist?
583                        (let ((attribute (symbol->http-name (car contents))))
584                          (if (eq? (cdr contents) #t)
585                              (unparse-token attribute)
586                              (sprintf "~A=~A"
587                                       attribute
588                                       (unparse-token (cdr contents))))))
589                       ((uri-reference? contents)
590                        (unparse-token (uri->string contents) (char-set)))
591                       (else (unparse-token contents))))
592               (parameter-unparsers '())) ; Maybe we want to make this a param
593          (loop (cdr headers)
594                (cons
595                 (string-append
596                  value
597                  (unparse-params (get-params (car headers))
598                                  parameter-unparsers))
599                 result))))))
600
601(define (entity-tag-unparser header-name header-contents)
602  (let ((contents (get-value (car header-contents))))
603    (string-append
604     (if (eq? 'weak (car contents)) "W/" "")
605     (if (string-prefix? "W/" (cdr contents))
606         (quote-string (cdr contents))
607         (unparse-token (cdr contents))))))
608
609(define (host/port-unparser header-name header-contents)
610  (let ((contents (get-value (car header-contents))))
611    ;; XXX: urlencode?
612    (if (= (cdr contents) 80)
613        (car contents)
614        (conc (car contents) ":" (cdr contents)))))
615
616(define (cookie-unparser header-name header-contents)
617  (let loop ((prefix "")
618             (headers (reverse header-contents))
619             (result '()))
620    (if (null? headers)
621        (conc prefix (string-join result "; "))
622        (let* ((version (get-param 'version (car headers) #f))
623               (params (alist-delete 'version (get-params (car headers))))
624               (unparsed-params
625                (map (lambda (p)
626                       (if (eq? (cdr p) #t)
627                           (unparse-token (conc "$" (symbol->http-name (car p))))
628                           (sprintf "~A=~A"
629                                    (unparse-token
630                                     (conc "$" (symbol->http-name (car p))))
631                                    (cond
632                                     ((and (eq? (car p) 'port) (pair? (cdr p)))
633                                      (string-join
634                                       (map number->string (cdr p)) ","))
635                                     (else (unparse-token (cdr p)))))))
636                     ;; Remove #f values
637                     (filter (lambda (p) (cdr p)) params)))
638               (cookie (get-value (car headers)))
639               (unparsed-cookie (sprintf "~A=~A"
640                                         (unparse-token (car cookie))
641                                         (unparse-token (cdr cookie)))))
642          ;; Doing it like this means we can't unparse cookies of
643          ;; mixed versions...
644          (loop (if version (sprintf "$Version: ~A; " version) prefix)
645                (cdr headers)
646                (cons (string-join (cons unparsed-cookie unparsed-params) "; ")
647                      result))))))
648
649(define (product-unparser header-name header-contents)
650  (string-join
651   (map (lambda (content)
652          (conc (first content)
653                (if (second content)
654                    (conc "/" (second content))
655                    "")
656                (if (third content)
657                    (conc " (" (third content) ")")
658                    "")))
659        (get-value (car header-contents)))))
660
661(define (rfc1123-unparser header-name header-contents)
662  (let-locale ((LC_TIME "POSIX"))
663              (time->string (get-value (car header-contents))
664                            "%a, %d %b %Y %X GMT")))
665
666(define (authorization-unparser header-name header-contents)
667  (let loop ((headers (reverse header-contents))
668             (result '()))
669    (if (null? headers)
670        (string-join result ", ")  ; XXX will this work?
671        (let ((contents               
672               (case (get-value (car headers))
673                 ((basic)
674                  (let ((user (get-param 'username (car headers)))
675                        (pass (get-param 'password (car headers))))
676                   (if (string-index user #\:)
677                       (signal-http-condition "Colon detected in username. This is not supported by basic auth!"
678                                              'username-with-colon 'value user)
679                       (sprintf "Basic ~A"
680                                (base64-encode
681                                 (sprintf "~A:~A" user pass))))))
682                 ((digest)
683                  (sprintf "~A ~A"
684                           (symbol->http-name (get-value (car headers)))
685                           (unparse-params (get-params (car headers))
686                                           `((nc . ,identity) ;; see below
687                                             (uri . ,uri->string)
688                                             (qop . ,symbol->string)
689                                             (algorithm . ,symbol->string))
690                                           separator: ", "
691                                           grammar: 'infix
692                                           keyword-unparser: symbol->string
693                                           value-unparser:
694                                           ;; Nasty exception for "nc", an
695                                           ;; an unquoted padded integer...
696                                           (lambda (x)
697                                             (if (number? x)
698                                                 (string-pad
699                                                  (number->string x 16)
700                                                  8 #\0)
701                                                 (quote-string (->string x)))))))
702                 (else
703                  (sprintf "~A ~A"
704                           (symbol->http-name (get-value (car headers)))
705                           (unparse-params (get-params (car headers)) '()))))))
706         (loop (cdr headers) (cons contents result))))))
707
708(define (authenticate-unparser header-name header-contents)
709  (let loop ((headers (reverse header-contents))
710             (result '()))
711    (if (null? headers)
712        (string-join result ", ")  ; XXX will this work?
713        (let ((contents
714               (sprintf "~A ~A"
715                        (symbol->http-name (get-value (car headers)))
716                        (let* ((old (get-params (car headers)))
717                               ;; A quick hack to get presence of "stale"
718                               ;; coded as TRUE instead of value-less param
719                               ;; false value is coded by its absense
720                               (params (if (alist-ref 'stale old)
721                                           (alist-update! 'stale 'TRUE old)
722                                           (alist-delete 'stale old))))
723                         (unparse-params params
724                                         `((domain . ,(lambda (u)
725                                                        (string-join
726                                                         (map uri->string u))))
727                                           (qop . ,(lambda (q)
728                                                     (string-join
729                                                      (map symbol->string q)
730                                                      ",")))
731                                           (algorithm . ,symbol->string))
732                                         separator: ", "
733                                         grammar: 'infix
734                                         keyword-unparser: symbol->string
735                                         value-unparser:
736                                         (lambda (x)
737                                           (if (eq? x 'TRUE)
738                                               "TRUE"
739                                               (quote-string (->string x)))))))))
740         (loop (cdr headers) (cons contents result))))))
Note: See TracBrowser for help on using the repository browser.