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

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

Remove (reasonably) pointless header-list-ref procedure. Just a case of premature optimization, that one. Maybe later we can put it back

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