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

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

Rearrange code so it has a more logical source order. Rename all subparsers so they end in -subparser (finding bugs in the process). Fix export list

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           )
206       (dynamic-wind
207           (lambda () (set! backup '((cat . ,(setlocale cat val)) ...)))
208           (lambda () body ...)
209           (lambda () (setlocale cat (alist-ref backup 'cat)) ...))))))
210
211(define (rfc1123-string->time str)
212  (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)
213       (let-locale ((LC_TIME "POSIX"))
214                   (string->time str "%a, %d %b %Y %X GMT"))))
215
216(define (rfc850-string->time str)
217  (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)
218      (let-locale ((LC_TIME "POSIX"))
219                  (string->time str "%a, %d-%b-%y %X GMT"))))
220
221(define (asctime-string->time str)
222  (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)
223       (let-locale ((LC_TIME "POSIX"))
224                   (string->time str "%a %b %d %X %Y"))))
225
226(define http-date-string->time
227  (disjoin rfc1123-string->time rfc850-string->time asctime-string->time))
228
229(define (rfc1123-subparser str)
230  (or (rfc1123-string->time str)
231      (signal-http-condition "Error parsing RFC 1123 date/time"
232                             'rfc1123-subparser 'value str)))
233
234(define (rfc850-subparser str)
235  (or (rfc850-string->time str)
236      (signal-http-condition "Error parsing RFC850 date/time"
237                             'asctime-subparser 'value str)))
238
239(define (asctime-subparser str)
240  (or (asctime-string->time str)
241      (signal-http-condition "Error parsing asctime() date/time"
242                             'asctime-subparser 'value str)))
243
244;; rfc1123-date | rfc850-date | asctime-date
245(define (http-date-subparser str)
246  (or (http-date-string->time str)
247      (signal-http-condition "Error parsing date/time"
248                             'http-date-subparser 'value str)))
249
250;; Change the accuracy of a number to 'digits' number of digits to the
251;; right of the decimal point.
252(define (chop-number num digits)
253  (let ((factor (expt 10 digits)))
254    (/ (round (* num factor)) factor)))
255
256(define (quality-subparser str)
257  ;; Anything that's not a number is seen as if the value is missing, hence 1.0
258  (let* ((num       (or (string->number str) 1.0))
259         (imprecise (chop-number num 3)))
260    (max 0.0 (min 1.0 imprecise))))
261
262;; Just put all header strings in a list, so we can pass it on
263;; Make no assumptions about the contents (only value, don't try to parse params)
264;; This is different from (multiple (without-params generic-header-parser))
265;; because this does not assume it can split up comma-separated values
266(define (unknown-header-parser name contents headers)
267  (update-header-contents! name (list (vector contents '())) headers))
268
269(define symbol-subparser
270  (compose string->symbol string-trim-both))
271
272(define symbol-subparser-ci
273  (compose string->symbol string-trim-both string-downcase))
274
275(define (natnum-subparser contents)
276  (let ((num (string->number contents)))
277    (if num (inexact->exact (max 0 (round num))) 0)))
278
279(define (host/port-subparser contents)
280  (let ((idx (string-index-right contents #\:)))
281    (if idx
282        (cons (substring/shared contents 0 idx)
283              (inexact->exact
284               (round (or (string->number (substring/shared contents (add1 idx)))
285                          80))))
286        (cons contents 80))))
287
288; base64 of 128 bit hex digest as per RFC1864 (eg, Content-md5)
289(define base64-subparser base64-decode)
290
291;; bytes <start>-<end>/<total>
292(define (range-subparser s)
293  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
294            (map string->number (drop parts 1))))
295
296;; [W/]<string>
297;; This is a full parser, because it needs to be able to distinguish
298;; between W/"foo" and "W/foo". If it's preprocessed by the tokenizer
299;; both get "normalised" to the same thing: W/foo
300;;
301;; XXX It could be a good idea if the single/multiple token parsers
302;; did not do anything to their contents.  If the consuming parsers
303;; want tokens, they know how to have it. OTOH, it would mean much
304;; more code for all the parsers as they need to tokenize more...
305(define (entity-tag-parser name contents headers)
306  (let ((contents (string-trim-both contents)))
307    (replace-header-contents!
308     name
309     (list (if (string-prefix? "W/" contents)
310               (vector `(weak . ,(parse-token contents 2 (char-set))) '())
311               (vector `(strong . ,(parse-token contents 0 (char-set))) '())))
312     headers)))
313
314;; ( <product>[/<version>] [<comment>] )+
315;; This parser is a full parser because parse-token cannot handle
316;; comments yet... (if a ; is in a comment, it breaks down)
317(define (product-parser name contents headers)
318  (replace-header-contents!
319   name
320   (let loop ((start-pos 0)
321              (products '()))
322     (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\()))
323                   ((version pos2) (parse-token contents pos ; (add1 pos)
324                                                (char-set-union (char-set #\()
325                                                                char-set:whitespace)))
326                   ((comment pos3) (parse-comment contents pos2))
327                   ;; Ugh
328                   ((real-version) (and version (not (string-null? version)) (string-trim version #\/))))
329       (if product
330           (loop pos3 (cons (list product real-version comment) products))
331           (list (vector (reverse products) '())))))
332   headers))
333
334;;;; MAJOR TODOs
335;; RFC1123 mailbox parser - just strings for now
336(define mailbox-subparser identity)
337
338;; Either an entity-tag or a http-date
339(define (if-range-parser name contents header)
340  (let ((http-date ((with-params http-date-string->time '()) contents)))
341    (if (get-value http-date)
342        (replace-header-contents! name (list http-date) header)
343        (entity-tag-parser name contents header))))
344
345;; Either delta-seconds or http-date
346(define retry-after-subparser (disjoin http-date-subparser natnum-subparser))
347
348;; Tricky - see 2616 14.45
349;; We probably shouldn't try to do too much parsing here
350(define via-parser (multiple identity))
351
352;; Tricky - see 2616 14.46
353(define warning-parser (multiple identity))
354;;;; END MAJOR TODOs
355
356(define (key/value-subparser str)
357  (let ((idx (string-index str #\=)))
358    (cons (string-take str idx) (string-drop str (add1 idx)))))
359
360;; The 'expires' header defined by the Netscape cookie spec contains
361;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
362(define (old-style-cookie? cookie)
363  (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))
364
365(define set-cookie-parser
366  (let ((param-subparsers `((expires . ,rfc850-subparser)
367                            (max-age . ,string->number)
368                            (version . ,string->number))))
369    (lambda (name contents headers)
370      (if (old-style-cookie? contents)
371          (update-header-contents!
372           name
373           (list ((with-params key/value-subparser param-subparsers) contents))
374           headers)
375          ((multiple key/value-subparser param-subparsers) name contents headers)))))
376
377(define cache-control-parser
378  (let ((splitter (lambda (str) ;; Is this correct?
379                    (map (compose string->symbol string-trim-both)
380                         (string-split str ",")))))
381    (multiple
382     (make-key/values-subparser `((max-age . ,natnum-subparser)
383                                  (s-maxage . ,natnum-subparser)
384                                  (max-stale . ,natnum-subparser)
385                                  (min-fresh . ,natnum-subparser)
386                                  (private . ,splitter)
387                                  (no-cache . ,splitter))))))
388
389(define pragma-parser
390  (multiple (make-key/values-subparser `())))
391
392(define te-parser
393  (multiple (make-key/values-subparser `((q . ,quality-subparser)))))
394
395;; Cookie headers are also braindead: there can be several cookies in one header,
396;; separated by either commas or semicolons. The only way to distinguish a
397;; new cookie from a parameter of the current cookie is the dollar in front
398;; of all parameter names.
399;; Also, there's a $Version attribute that prepends all cookies, which is
400;; considered to apply to all cookies that follow.
401;;
402;; This code is a bit of a hack in the way it abuses parse-parameters
403(define (cookie-parser name value headers)
404  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
405  (define (split-attribs pairs)
406    (span (lambda (pair)
407            (string-prefix? "$" (symbol->string (car pair))))
408          pairs))
409  (receive (params pos)
410    (parse-parameters value 0 `(($version . ,string->number)
411                               ($port . ,string->number)))
412    (receive (global-attrs remaining)
413      (split-attribs params)
414      (let loop ((remaining remaining)
415                 (cookies '()))
416        (if (null? remaining)
417            (update-header-contents! name (reverse cookies) headers)
418            (let ((cookie (cons (symbol->string (caar remaining))
419                                (cdar remaining)))
420                  (params (cdr remaining)))
421              (receive (local-attrs rest)
422                (split-attribs params)
423                (let* ((all-attrs (append global-attrs local-attrs))
424                       (result (vector cookie all-attrs)))
425                  (loop rest (cons result cookies))))))))))
426
427;;; Unparsers ;;;
428(define (unparse-params params unparsers)
429  (let loop ((params params)
430             (results '()))
431    (if (null? params)
432        (string-join (reverse results) "; " 'prefix)
433        (let* ((unparser (alist-ref unparsers (caar params) eq?
434                                    (lambda (attribute value)
435                                      (case value
436                                        ;; #t means param is present (no value)
437                                        ((#t) (symbol->http-name attribute))
438                                        ;; #f means param is missing
439                                        ((#f) #f)
440                                        (else
441                                         (sprintf "~A=~A"
442                                                  (symbol->http-name attribute)
443                                                  value))))))
444               (str (unparser (caar params) (cdar params))))
445          (loop (cdr params) (if str (cons str results) results))))))
446
447(define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
448
449(define quote-string
450  (let ((smap (map (lambda (c)
451                     (cons (string c)
452                           (string-append "\\" (string c))))
453                   (char-set->list must-be-quoted-chars))))
454    (lambda (string)
455      (let ((error-chars (char-set #\newline)))
456        (if (string-any error-chars string)
457            (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
458                                   'unencoded-header 'value string)
459            (string-append "\"" (string-translate* string smap) "\""))))))
460
461;; Unparse a value as token, converting it to a string first
462(define unparse-token
463  (let* ((trigger-quoting-chars (char-set-union
464                                 (char-set-adjoin must-be-quoted-chars #\, #\; #\=)
465                                 char-set:blank)))
466   (lambda (token)
467     (let ((token-string (->string token)))
468      (if (string-any trigger-quoting-chars token-string)
469          (quote-string token-string)
470          token-string)))))
471
472;; There's no need to make a specific header unparser for every header type.
473;; Usually, the Scheme value representing a header can unambiguously be
474;; unparsed into a header just by checking its type.
475(define (default-header-unparser header-name header-contents)
476  (let loop ((headers (reverse header-contents))
477             (result '()))
478    (if (null? headers)
479        (string-join result ", ")
480        (let* ((contents (get-value (car headers)))
481               (value (cond
482                       ((pair? contents) ; alist?
483                        (let ((attribute (symbol->http-name (car contents))))
484                          (if (eq? (cdr contents) #t)
485                              (unparse-token attribute)
486                              (sprintf "~A=~A"
487                                       attribute
488                                       (unparse-token (cdr contents))))))
489                       ((uri-reference? contents) (unparse-token (uri->string contents)))
490                       (else (unparse-token contents))))
491               (parameter-unparsers '())) ; Maybe we want to make this a param
492          (loop (cdr headers)
493                (cons
494                 (string-append
495                  value
496                  (unparse-params (get-params (car headers))
497                                  parameter-unparsers))
498                 result))))))
499
500(define (entity-tag-unparser header-name header-contents)
501  (let ((contents (get-value (car header-contents))))
502    (string-append
503     (if (eq? 'weak (car contents)) "W/" "")
504     (if (string-prefix? "W/" (cdr contents))
505         (quote-string (cdr contents))
506         (unparse-token (cdr contents))))))
507
508(define (host/port-unparser header-name header-contents)
509  (let ((contents (get-value (car header-contents))))
510    ;; XXX: urlencode?
511    (if (= (cdr contents) 80)
512        (car contents)
513        (conc (car contents) ":" (cdr contents)))))
514
515(define (product-unparser header-name header-contents)
516  (string-join
517   (map (lambda (content)
518          (conc (first content)
519                (if (second content)
520                    (conc "/" (second content))
521                    "")
522                (if (third content)
523                    (conc " (" (third content) ")")
524                    "")))
525        (get-value (car header-contents)))))
526
527(define (rfc1123-unparser header-name header-contents)
528  (let-locale ((LC_TIME "POSIX"))
529              (time->string (get-value (car header-contents))
530                            "%a, %d %b %Y %X GMT")))
Note: See TracBrowser for help on using the repository browser.