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

Last change on this file since 14361 was 14361, checked in by Jim Ursetto, 11 years ago

intarweb: dep on regex-case, use base64 3.0 API

File size: 20.1 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 #!optional (default #f))
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 (attribute-name pos)
158      (parse-token string start-pos (char-set #\; #\=))
159      (if attribute-name
160          (let ((attribute (http-name->symbol attribute-name)))
161            (if (and (< pos (string-length string))
162                     (char=? (string-ref string pos) #\=))
163                (receive (value pos)
164                  (parse-token string (add1 pos) (char-set #\;))
165                  ;; In case of no value ("foo="), use the empty string as value
166                  (let ((value ((alist-ref attribute param-parsers eq? identity)
167                                (or value ""))))
168                    (loop (add1 pos) (cons (cons attribute value) params))))
169                ;; Missing value is interpreted as "present",
170                ;; so #t. If not present, it's #f when looking it up
171                (loop (add1 pos) (cons (cons attribute #t) params))))
172          (values (reverse params) pos)))))
173
174(define (parse-value+parameters string start-pos value-parser param-parsers)
175  (receive (value pos)
176    (parse-token string start-pos (char-set #\;))
177    (if (not value)
178        (values #f pos) ;; XXX this is wrong and not expected by the caller!
179        (receive (params pos)
180          (parse-parameters string (add1 pos) param-parsers)
181          (values (vector (value-parser value) params) pos)))))
182
183(define (with-params value-parser parameter-parsers)
184  (lambda (entry)
185    (receive (type+params pos)
186      (parse-value+parameters entry 0 value-parser parameter-parsers)
187      type+params)))
188
189(define (multiple other-parser #!optional (parameter-parsers '()))
190  (lambda (name entries headers)
191    (fold (lambda (entry headers)
192            (update-header-contents!
193             name
194             (list ((with-params other-parser parameter-parsers) entry))
195             headers))
196          headers
197          (split-multi-header entries))))
198
199(define (single other-parser #!optional (parameter-parsers '()))
200  (lambda (name contents headers)
201    (replace-header-contents!
202     name
203     (list ((with-params other-parser parameter-parsers) contents))
204     headers)))
205
206(define (key/values key/value-parsers)
207  (lambda (k/v)
208    ;; We're abusing parse-parameters here to read value
209    ;; instead of params.  This is weird, but it works :)
210    (receive (key+value pos)
211      (parse-parameters k/v 0 key/value-parsers)
212      (car key+value))))
213
214(define symbol-parser-ci
215  (compose string->symbol string-trim-both string-downcase))
216
217(define symbol-parser
218  (compose string->symbol string-trim-both))
219
220(define (natnum-parser contents)
221  (let ((num (string->number contents)))
222    (if num (inexact->exact (max 0 (round num))) 0)))
223
224(define (host-parser contents)
225  (let ((idx (string-index-right contents #\:)))
226    (if idx
227        (cons (substring/shared contents 0 idx)
228              (inexact->exact
229               (round (or (string->number (substring/shared contents (add1 idx)))
230                          80))))
231        (cons contents 80))))
232
233; base64 of 128 bit hex digest as per RFC1864
234(define md5-parser base64-decode)
235
236;; bytes <start>-<end>/<total>
237(define (range-parser s)
238  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
239            (map string->number (drop parts 1))))
240
241;; rfc1123-date | rfc850-date | asctime-date
242(define http-time-parser rfc822-time-parser)
243
244;; [W/]<string>
245;; This is a full parser, because it needs to be able to distinguish
246;; between W/"foo" and "W/foo". If it's preprocessed by the tokenizer
247;; both get "normalised" to the same thing: W/foo
248;;
249;; XXX It could be a good idea if the single/multiple token parsers
250;; did not do anything to their contents.  If the consuming parsers
251;; want tokens, they know how to have it. OTOH, it would mean much
252;; more code for all the parsers as they need to tokenize more...
253(define (entity-tag-parser name contents headers)
254  (let ((contents (string-trim-both contents)))
255    (replace-header-contents!
256     name
257     (list (if (string-prefix? "W/" contents)
258               (vector `(weak . ,(parse-token contents 2 (char-set))) '())
259               (vector `(strong . ,(parse-token contents 0 (char-set))) '())))
260     headers)))
261
262;; ( <product>[/<version>] [<comment>] )+
263;; This parser is a full parser because parse-token cannot handle
264;; comments yet... (if a ; is in a comment, it breaks down)
265(define (product-parser name contents headers)
266  (replace-header-contents!
267   name
268   (let loop ((start-pos 0)
269              (products '()))
270     (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\()))
271                   ((version pos2) (parse-token contents pos ; (add1 pos)
272                                                (char-set-union (char-set #\()
273                                                                char-set:whitespace)))
274                   ((comment pos3) (parse-comment contents pos2))
275                   ;; Ugh
276                   ((real-version) (and version (not (string-null? version)) (string-trim version #\/))))
277       (if product
278           (loop pos3 (cons (list product real-version comment) products))
279           (list (vector (reverse products) '())))))
280   headers))
281
282;;;; MAJOR TODOs
283;; RFC822/1123 mailbox parser - just strings for now
284(define mailbox-parser identity)
285
286;; Either an entity-tag or a http-date
287(define if-range-parser identity)
288
289;; Either delta-seconds or RFC822 timestamp
290(define (retry-after-parser contents)
291  (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
292      (natnum-parser contents)
293      (rfc822-time-parser contents)))
294
295;; Tricky - see 2616 14.45
296;; We probably shouldn't try to do too much parsing here
297(define via-parser (multiple identity))
298
299;; Tricky - see 2616 14.46
300(define warning-parser (multiple identity))
301;;;; END MAJOR TODOs
302
303(define (key/value-parser str)
304  (let ((idx (string-index str #\=)))
305    (cons (string-take str idx) (string-drop str (add1 idx)))))
306
307;; The 'expires' header defined by the Netscape cookie spec contains
308;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
309(define (old-style-cookie? cookie)
310  (not (not (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))))
311
312(define set-cookie-parser
313  (let ((param-parsers `((expires . ,rfc822-time-parser)
314                         (max-age . ,string->number)
315                         (version . ,string->number))))
316    (lambda (name contents headers)
317      (if (old-style-cookie? contents)
318          (update-header-contents!
319           name
320           (list ((with-params key/value-parser param-parsers) contents))
321           headers)
322          ((multiple key/value-parser param-parsers) name contents headers)))))
323
324(define cache-control-parser
325  (let ((splitter (lambda (str) ;; Is this correct?
326                    (map (compose string->symbol string-trim-both)
327                         (string-split str ",")))))
328    (multiple
329     (key/values `((max-age . ,natnum-parser)
330                   (s-maxage . ,natnum-parser)
331                   (max-stale . ,natnum-parser)
332                   (min-fresh . ,natnum-parser)
333                   (private . ,splitter)
334                   (no-cache . ,splitter))))))
335
336(define pragma-parser
337  (multiple (key/values `())))
338
339(define te-parser
340  (multiple (key/values `((q . ,quality-parser)))))
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 (attribute value)
382                                      (case value
383                                        ;; #t means param is present (no value)
384                                        ((#t) (symbol->http-name attribute))
385                                        ;; #f means param is missing
386                                        ((#f) #f)
387                                        (else
388                                         (sprintf "~A=~A"
389                                                  (symbol->http-name attribute)
390                                                  value))))))
391               (str (unparser (caar params) (cdar params))))
392          (loop (cdr params) (if str (cons str results) results))))))
393
394(define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
395
396(define quote-string
397  (let ((smap (map (lambda (c)
398                     (cons (string c)
399                           (string-append "\\" (string c))))
400                   (char-set->list must-be-quoted-chars))))
401    (lambda (string)
402      (let ((error-chars (char-set #\newline)))
403        (if (string-any error-chars string)
404            (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
405                                   'unencoded-header 'value string)
406            (string-append "\"" (string-translate* string smap) "\""))))))
407
408;; Unparse a value as token, converting it to a string first
409(define unparse-token
410  (let* ((trigger-quoting-chars (char-set-union
411                                 (char-set-adjoin must-be-quoted-chars #\, #\; #\=)
412                                 char-set:blank)))
413   (lambda (token)
414     (let ((token-string (->string token)))
415      (if (string-any trigger-quoting-chars token-string)
416          (quote-string token-string)
417          token-string)))))
418
419;; There's no need to make a specific header unparser for every header type.
420;; Usually, the Scheme value representing a header can unambiguously be
421;; unparsed into a header just by checking its type.
422(define (default-header-unparser header-name header-contents)
423  (let loop ((headers (reverse header-contents))
424             (result '()))
425    (if (null? headers)
426        (string-join result ", ")
427        (let* ((contents (get-value (car headers)))
428               (value (cond
429                       ((pair? contents) ; alist?
430                        (let ((attribute (symbol->http-name (car contents))))
431                          (if (eq? (cdr contents) #t)
432                              (unparse-token attribute)
433                              (sprintf "~A=~A"
434                                       attribute
435                                       (unparse-token (cdr contents))))))
436                       ((uri-reference? contents) (unparse-token (uri->string contents)))
437                       (else (unparse-token contents))))
438               (parameter-unparsers '())) ; Maybe we want to make this a param
439          (loop (cdr headers)
440                (cons
441                 (string-append
442                  value
443                  (unparse-params (get-params (car headers))
444                                  parameter-unparsers))
445                 result))))))
446
447(define (entity-tag-unparser header-name header-contents)
448  (let ((contents (get-value (car header-contents))))
449    (string-append
450     (if (eq? 'weak (car contents)) "W/" "")
451     (if (string-prefix? "W/" (cdr contents))
452         (quote-string (cdr contents))
453         (unparse-token (cdr contents))))))
454
455(define (host-unparser header-name header-contents)
456  (let ((contents (get-value (car header-contents))))
457    ;; XXX: urlencode?
458    (if (= (cdr contents) 80)
459        (car contents)
460        (conc (car contents) ":" (cdr contents)))))
461
462(define (product-unparser header-name header-contents)
463  (string-join
464   (map (lambda (content)
465          (conc (first content)
466                (if (second content)
467                    (conc "/" (second content))
468                    "")
469                (if (third content)
470                    (conc " (" (third content) ")")
471                    "")))
472        (get-value (car header-contents)))))
Note: See TracBrowser for help on using the repository browser.