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

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

Fix bugs in let-locale found by scrutiny

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