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

Last change on this file since 14572 was 14572, checked in by sjamaan, 11 years ago

Implement http-date unparsers. Change all date unparsers to http-date-unparsers

File size: 22.2 KB
Line 
1;; Change the accuracy of a number to 'digits' number of digits to the
2;; right of the decimal point.
3(define (chop-number num digits)
4  (let ((factor (expt 10 digits)))
5    (/ (round (* num factor)) factor)))
6
7(define (quality-parser str)
8  ;; Anything that's not a number is seen as if the value is missing, hence 1.0
9  (let* ((num       (or (string->number str) 1.0))
10         (imprecise (chop-number num 3)))
11    (max 0.0 (min 1.0 imprecise))))
12
13(foreign-declare "#include <locale.h>")
14
15(define setlocale (foreign-lambda c-string setlocale int c-string))
16
17(define-foreign-variable LC_TIME int)
18
19(define-syntax let-locale
20  (syntax-rules ()
21    ((let-locale ((cat val) ...) body ...)
22     (let ((backup '()))
23       (dynamic-wind
24           (lambda () (set! backup '((cat . ,(setlocale cat val)) ...)))
25           (lambda () body ...)
26           (lambda () (setlocale cat (alist-ref backup 'cat)) ...))))))
27
28(define (rfc1123-string->time str)
29  (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat), [0-9]{2} (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [0-9]{4} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
30       (let-locale ((LC_TIME "POSIX"))
31                   (string->time str "%a, %d %b %Y %X GMT"))))
32
33(define (rfc1123-parser str)
34  (or (rfc1123-string->time str)
35      (signal-http-condition "Error parsing RFC 1123 date/time"
36                             'rfc1123-parser 'value str)))
37
38(define (rfc850-string->time str)
39  (and (string-search "(Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday), [0-9]{2}-(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)-[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
40      (let-locale ((LC_TIME "POSIX"))
41                  (string->time str "%a, %d-%b-%y %X GMT"))))
42
43(define (rfc850-parser str)
44  (or (rfc850-string->time str)
45      (signal-http-condition "Error parsing RFC850 date/time"
46                             'asctime-parser 'value str)))
47
48(define (asctime-string->time str)
49  (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)  ?[0-9]{1,2} [0-9]{2}:[0-9]{2}:[0-9]{2} [0-9]{4}" str)
50       (let-locale ((LC_TIME "POSIX"))
51                   (string->time str "%a %b %d %X %Y"))))
52
53(define (asctime-parser str)
54  (or (asctime-string->time str)
55      (signal-http-condition "Error parsing asctime() date/time"
56                             'asctime-parser 'value str)))
57
58;; Get the raw contents of a header
59(define (header-contents name headers #!optional (default #f))
60  (alist-ref name (headers-v headers) eq? default))
61
62;; Get all values of a header
63(define (header-values header-name headers)
64  (map (cut vector-ref <> 0) (header-contents header-name headers '())))
65
66;; Get the value of a header, assuming it has only one value
67(define (header-value header-name headers #!optional (default #f))
68  (let ((contents (header-contents header-name headers '())))
69    (if (null? contents)
70        default
71        (get-value (car contents)))))
72
73;; Get the value from one header entry
74(define get-value (cut vector-ref <> 0))
75
76;; Get all params from one header entry
77(define get-params (cut vector-ref <> 1))
78
79;; Get one specific parameter from one header entry
80(define (get-param param contents #!optional (default #f))
81  (alist-ref param (vector-ref contents 1) eq?))
82
83;; Get-param, except if no quality is present return 1
84(define (get-quality header-contents)
85  (or (get-param 'q header-contents) 1.0))
86
87;;;; Header parsers
88
89;; Find a matching endpoint for a token, ignoring escaped copies of the token
90(define (escaped-string-end str start stop-char-set)
91  (let ((len (string-length str)))
92    (let loop ((start start))
93      (let ((pos (string-index str (char-set-adjoin stop-char-set #\\) start)))
94        (if pos
95            (if (char=? #\\ (string-ref str pos))
96                ;; Escaped matching closing symbol
97                (if (= len (add1 pos))
98                    pos
99                    (loop (+ pos 2)))
100                ;; Reached the matching closing symbol
101                pos)
102            len))))) ; No matching closing symbol?  "Insert" it at the end
103
104;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
105(define (split-multi-header value)
106  (let ((len (string-length value)))
107    (let loop ((result '())
108               (start-pos 0)   ; Where the current header value starts
109               (search-pos 0)) ; Where the searching starts
110      (or (and-let* (((< search-pos len))
111                     (pos (string-index value (char-set #\, #\") search-pos)))
112            (if (char=? #\, (string-ref value pos))
113                (loop (cons (string-copy value start-pos pos) result) (add1 pos) (add1 pos))
114                (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\"))))
115                  (loop result start-pos (add1 end-pos)))))
116          (reverse (cons (string-drop value start-pos) result))))))
117
118;; Remove all escape characters from the input, recognising "escaped escapes"
119(define (unescape str)
120  (let ((last-char (sub1 (string-length str))))
121    (let loop ((result "")
122               (start-pos 0))
123      (or (and-let* ((pos (string-index str #\\ start-pos)))
124            (if (= pos last-char)
125                (string-append result (string-copy str start-pos))
126                (loop (string-append result (string-copy str start-pos pos)
127                                     (string-copy str (add1 pos) (+ pos 2)))
128                      (+ pos 2))))
129          (string-append result (string-copy str start-pos))))))
130
131;; Try to parse a token, starting at the provided offset, up until the
132;; char-set where we should stop.  Returns two values: the token or #f if
133;; there is no token left, and the position on which the token ends.
134(define (parse-token value start-pos stop-char-set)
135  (if (>= start-pos (string-length value))
136      (values #f start-pos)
137      (let ((stop (char-set-adjoin stop-char-set #\")))
138        (let ((pos (string-index value stop start-pos)))
139          (if pos
140              (if (not (char=? #\" (string-ref value pos)))
141                  (values (string-trim-both (string-copy value start-pos pos))
142                          pos) ; Stop-char found, but no quoting
143                  (let ((end-pos (escaped-string-end value (add1 pos)
144                                                     (char-set #\"))))
145                    ;; Found the double quote? Recurse on the remainder
146                    (receive (rest final-pos)
147                      (parse-token value (add1 end-pos) stop-char-set)
148                      (values (string-append
149                               (string-trim-both
150                                (string-copy value start-pos pos))
151                               (if (= pos end-pos)
152                                   (unescape (string-copy value (add1 pos)))
153                                   (unescape (string-copy value (add1 pos) end-pos)))
154                               (or rest ""))
155                              final-pos))))
156              ;; Nothing found?  Then the remainder of the string is the token
157              (values (string-trim-both (string-copy value start-pos))
158                      (string-length value)))))))
159
160;; Comments are a bit like tokens, except they can be nested
161(define (parse-comment value start-pos)
162  (let* ((len (string-length value))
163         (nospace-pos (and (< start-pos len)
164                           (string-skip value char-set:whitespace start-pos))))
165    (if (and nospace-pos (char=? (string-ref value nospace-pos) #\())
166        (let loop ((result "")
167                   (start-pos (add1 nospace-pos)))
168          (if (>= start-pos len)
169              (values result len)
170              (let ((pos (string-index value (char-set #\( #\)) start-pos)))
171                (if pos
172                    (if (char=? #\( (string-ref value pos)) ; Nested comment
173                        (receive (nested end-pos)
174                          (parse-comment value pos)
175                          (loop (sprintf "~A~A(~A)"
176                                         result
177                                         (string-copy value start-pos pos)
178                                         nested)
179                                (add1 end-pos)))
180                        ;; Else it's a )
181                        (values (conc result (string-copy value start-pos pos)) (add1 pos)))
182                    ;; Nothing found?  Then the remainder of the string is the token
183                    (values (conc result (string-copy value start-pos))
184                            (string-length value))))))
185        ;; No (? Then fail to match the 'comment'
186        (values #f start-pos))))
187
188;; Just put all header strings in a list, so we can pass it on
189;; Make no assumptions about the contents (only value, don't try to parse params)
190;; This is different from (multiple (without-params generic-header-parser))
191;; because this does not assume it can split up comma-separated values
192(define (unknown-header-parser name contents headers)
193  (update-header-contents! name (list (vector contents '())) headers))
194
195(define (parse-parameters string start-pos param-parsers)
196  (let loop ((start-pos start-pos)
197             (params '()))
198    (receive (attribute-name pos)
199      (parse-token string start-pos (char-set #\; #\=))
200      (if attribute-name
201          (let ((attribute (http-name->symbol attribute-name)))
202            (if (and (< pos (string-length string))
203                     (char=? (string-ref string pos) #\=))
204                (receive (value pos)
205                  (parse-token string (add1 pos) (char-set #\;))
206                  ;; In case of no value ("foo="), use the empty string as value
207                  (let ((value ((alist-ref attribute param-parsers eq? identity)
208                                (or value ""))))
209                    (loop (add1 pos) (cons (cons attribute value) params))))
210                ;; Missing value is interpreted as "present",
211                ;; so #t. If not present, it's #f when looking it up
212                (loop (add1 pos) (cons (cons attribute #t) params))))
213          (values (reverse params) pos)))))
214
215(define (parse-value+parameters string start-pos value-parser param-parsers)
216  (receive (value pos)
217    (parse-token string start-pos (char-set #\;))
218    (if (not value)
219        (values #f pos) ;; XXX this is wrong and not expected by the caller!
220        (receive (params pos)
221          (parse-parameters string (add1 pos) param-parsers)
222          (values (vector (value-parser value) params) pos)))))
223
224(define (with-params value-parser parameter-parsers)
225  (lambda (entry)
226    (receive (type+params pos)
227      (parse-value+parameters entry 0 value-parser parameter-parsers)
228      type+params)))
229
230(define (multiple other-parser #!optional (parameter-parsers '()))
231  (lambda (name entries headers)
232    (fold (lambda (entry headers)
233            (update-header-contents!
234             name
235             (list ((with-params other-parser parameter-parsers) entry))
236             headers))
237          headers
238          (split-multi-header entries))))
239
240(define (single other-parser #!optional (parameter-parsers '()))
241  (lambda (name contents headers)
242    (replace-header-contents!
243     name
244     (list ((with-params other-parser parameter-parsers) contents))
245     headers)))
246
247(define (key/values key/value-parsers)
248  (lambda (k/v)
249    ;; We're abusing parse-parameters here to read value
250    ;; instead of params.  This is weird, but it works :)
251    (receive (key+value pos)
252      (parse-parameters k/v 0 key/value-parsers)
253      (car key+value))))
254
255(define symbol-parser-ci
256  (compose string->symbol string-trim-both string-downcase))
257
258(define symbol-parser
259  (compose string->symbol string-trim-both))
260
261(define (natnum-parser contents)
262  (let ((num (string->number contents)))
263    (if num (inexact->exact (max 0 (round num))) 0)))
264
265(define (host-parser contents)
266  (let ((idx (string-index-right contents #\:)))
267    (if idx
268        (cons (substring/shared contents 0 idx)
269              (inexact->exact
270               (round (or (string->number (substring/shared contents (add1 idx)))
271                          80))))
272        (cons contents 80))))
273
274; base64 of 128 bit hex digest as per RFC1864
275(define md5-parser base64-decode)
276
277;; bytes <start>-<end>/<total>
278(define (range-parser s)
279  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
280            (map string->number (drop parts 1))))
281
282;; rfc1123-date | rfc850-date | asctime-date
283(define (http-date-parser str)
284  (or (rfc1123-string->time str)
285      (rfc850-string->time str)
286      (asctime-string->time str)
287      (signal-http-condition "Error parsing date/time"
288                             'http-date-parser 'value str)))
289
290;; [W/]<string>
291;; This is a full parser, because it needs to be able to distinguish
292;; between W/"foo" and "W/foo". If it's preprocessed by the tokenizer
293;; both get "normalised" to the same thing: W/foo
294;;
295;; XXX It could be a good idea if the single/multiple token parsers
296;; did not do anything to their contents.  If the consuming parsers
297;; want tokens, they know how to have it. OTOH, it would mean much
298;; more code for all the parsers as they need to tokenize more...
299(define (entity-tag-parser name contents headers)
300  (let ((contents (string-trim-both contents)))
301    (replace-header-contents!
302     name
303     (list (if (string-prefix? "W/" contents)
304               (vector `(weak . ,(parse-token contents 2 (char-set))) '())
305               (vector `(strong . ,(parse-token contents 0 (char-set))) '())))
306     headers)))
307
308;; ( <product>[/<version>] [<comment>] )+
309;; This parser is a full parser because parse-token cannot handle
310;; comments yet... (if a ; is in a comment, it breaks down)
311(define (product-parser name contents headers)
312  (replace-header-contents!
313   name
314   (let loop ((start-pos 0)
315              (products '()))
316     (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\()))
317                   ((version pos2) (parse-token contents pos ; (add1 pos)
318                                                (char-set-union (char-set #\()
319                                                                char-set:whitespace)))
320                   ((comment pos3) (parse-comment contents pos2))
321                   ;; Ugh
322                   ((real-version) (and version (not (string-null? version)) (string-trim version #\/))))
323       (if product
324           (loop pos3 (cons (list product real-version comment) products))
325           (list (vector (reverse products) '())))))
326   headers))
327
328;;;; MAJOR TODOs
329;; RFC1123 mailbox parser - just strings for now
330(define mailbox-parser identity)
331
332;; Either an entity-tag or a http-date
333(define if-range-parser identity)
334
335;; Either delta-seconds or http-date
336(define (retry-after-parser contents)
337  (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
338      (natnum-parser contents)
339      (http-date-parser contents)))
340
341;; Tricky - see 2616 14.45
342;; We probably shouldn't try to do too much parsing here
343(define via-parser (multiple identity))
344
345;; Tricky - see 2616 14.46
346(define warning-parser (multiple identity))
347;;;; END MAJOR TODOs
348
349(define (key/value-parser str)
350  (let ((idx (string-index str #\=)))
351    (cons (string-take str idx) (string-drop str (add1 idx)))))
352
353;; The 'expires' header defined by the Netscape cookie spec contains
354;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
355(define (old-style-cookie? cookie)
356  (not (not (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))))
357
358(define set-cookie-parser
359  (let ((param-parsers `((expires . ,rfc850-parser)
360                         (max-age . ,string->number)
361                         (version . ,string->number))))
362    (lambda (name contents headers)
363      (if (old-style-cookie? contents)
364          (update-header-contents!
365           name
366           (list ((with-params key/value-parser param-parsers) contents))
367           headers)
368          ((multiple key/value-parser param-parsers) name contents headers)))))
369
370(define cache-control-parser
371  (let ((splitter (lambda (str) ;; Is this correct?
372                    (map (compose string->symbol string-trim-both)
373                         (string-split str ",")))))
374    (multiple
375     (key/values `((max-age . ,natnum-parser)
376                   (s-maxage . ,natnum-parser)
377                   (max-stale . ,natnum-parser)
378                   (min-fresh . ,natnum-parser)
379                   (private . ,splitter)
380                   (no-cache . ,splitter))))))
381
382(define pragma-parser
383  (multiple (key/values `())))
384
385(define te-parser
386  (multiple (key/values `((q . ,quality-parser)))))
387
388;; Cookie headers are also braindead: there can be several cookies in one header,
389;; separated by either commas or semicolons. The only way to distinguish a
390;; new cookie from a parameter of the current cookie is the dollar in front
391;; of all parameter names.
392;; Also, there's a $Version attribute that prepends all cookies, which is
393;; considered to apply to all cookies that follow.
394;;
395;; This code is a bit of a hack in the way it abuses parse-parameters
396(define (cookie-parser name value headers)
397  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
398  (define (split-attribs pairs)
399    (span (lambda (pair)
400            (string-prefix? "$" (symbol->string (car pair))))
401          pairs))
402  (receive (params pos)
403    (parse-parameters value 0 `(($version . ,string->number)
404                               ($port . ,string->number)))
405    (receive (global-attrs remaining)
406      (split-attribs params)
407      (let loop ((remaining remaining)
408                 (cookies '()))
409        (if (null? remaining)
410            (update-header-contents! name (reverse cookies) headers)
411            (let ((cookie (cons (symbol->string (caar remaining))
412                                (cdar remaining)))
413                  (params (cdr remaining)))
414              (receive (local-attrs rest)
415                (split-attribs params)
416                (let* ((all-attrs (append global-attrs local-attrs))
417                       (result (vector cookie all-attrs)))
418                  (loop rest (cons result cookies))))))))))
419
420;;; Unparsers ;;;
421(define (unparse-params params unparsers)
422  (let loop ((params params)
423             (results '()))
424    (if (null? params)
425        (string-join (reverse results) "; " 'prefix)
426        (let* ((unparser (alist-ref unparsers (caar params) eq?
427                                    (lambda (attribute value)
428                                      (case value
429                                        ;; #t means param is present (no value)
430                                        ((#t) (symbol->http-name attribute))
431                                        ;; #f means param is missing
432                                        ((#f) #f)
433                                        (else
434                                         (sprintf "~A=~A"
435                                                  (symbol->http-name attribute)
436                                                  value))))))
437               (str (unparser (caar params) (cdar params))))
438          (loop (cdr params) (if str (cons str results) results))))))
439
440(define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
441
442(define quote-string
443  (let ((smap (map (lambda (c)
444                     (cons (string c)
445                           (string-append "\\" (string c))))
446                   (char-set->list must-be-quoted-chars))))
447    (lambda (string)
448      (let ((error-chars (char-set #\newline)))
449        (if (string-any error-chars string)
450            (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
451                                   'unencoded-header 'value string)
452            (string-append "\"" (string-translate* string smap) "\""))))))
453
454;; Unparse a value as token, converting it to a string first
455(define unparse-token
456  (let* ((trigger-quoting-chars (char-set-union
457                                 (char-set-adjoin must-be-quoted-chars #\, #\; #\=)
458                                 char-set:blank)))
459   (lambda (token)
460     (let ((token-string (->string token)))
461      (if (string-any trigger-quoting-chars token-string)
462          (quote-string token-string)
463          token-string)))))
464
465;; There's no need to make a specific header unparser for every header type.
466;; Usually, the Scheme value representing a header can unambiguously be
467;; unparsed into a header just by checking its type.
468(define (default-header-unparser header-name header-contents)
469  (let loop ((headers (reverse header-contents))
470             (result '()))
471    (if (null? headers)
472        (string-join result ", ")
473        (let* ((contents (get-value (car headers)))
474               (value (cond
475                       ((pair? contents) ; alist?
476                        (let ((attribute (symbol->http-name (car contents))))
477                          (if (eq? (cdr contents) #t)
478                              (unparse-token attribute)
479                              (sprintf "~A=~A"
480                                       attribute
481                                       (unparse-token (cdr contents))))))
482                       ((uri-reference? contents) (unparse-token (uri->string contents)))
483                       (else (unparse-token contents))))
484               (parameter-unparsers '())) ; Maybe we want to make this a param
485          (loop (cdr headers)
486                (cons
487                 (string-append
488                  value
489                  (unparse-params (get-params (car headers))
490                                  parameter-unparsers))
491                 result))))))
492
493(define (entity-tag-unparser header-name header-contents)
494  (let ((contents (get-value (car header-contents))))
495    (string-append
496     (if (eq? 'weak (car contents)) "W/" "")
497     (if (string-prefix? "W/" (cdr contents))
498         (quote-string (cdr contents))
499         (unparse-token (cdr contents))))))
500
501(define (host-unparser header-name header-contents)
502  (let ((contents (get-value (car header-contents))))
503    ;; XXX: urlencode?
504    (if (= (cdr contents) 80)
505        (car contents)
506        (conc (car contents) ":" (cdr contents)))))
507
508(define (product-unparser header-name header-contents)
509  (string-join
510   (map (lambda (content)
511          (conc (first content)
512                (if (second content)
513                    (conc "/" (second content))
514                    "")
515                (if (third content)
516                    (conc " (" (third content) ")")
517                    "")))
518        (get-value (car header-contents)))))
519
520(define (rfc1123-unparser header-name header-contents)
521  (let-locale ((LC_TIME "POSIX"))
522              (time->string (get-value (car header-contents))
523                            "%a, %d %b %Y %X GMT")))
Note: See TracBrowser for help on using the repository browser.