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

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

Final (hopefully) finetuning of product-unparser

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