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

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

Rework parsers a little so they can return lists of values instead of headers. It makes more sense this way and makes the code a bit shorter - and paves the way for more changes to come

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