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

Last change on this file since 11568 was 11568, checked in by sjamaan, 13 years ago

Make params/quality-only not so special

File size: 11.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  (let* ((num       (or (string->number str) 0))
9         (imprecise (chop-number num 3)))
10    (max 0.0 (min 1.0 imprecise))))
11
12;; TODO: Make this use SRFI-19
13(define (rfc822-time-parser str)
14  0)
15
16(define-record value+params value params)
17
18;; XXX: Define a procedure that's a combination of this and get-header-contents
19(define get-value value+params-value)
20(define (get-values headers) (map value+params-value headers))
21(define (header-list-ref value headers #!optional (equal? eq?))
22  (find (lambda (h) (equal? (car (get-value h)) value)) headers))
23
24(define (get-param param contents)
25  (alist-ref param (value+params-params contents) eq?))
26
27(define (get-quality header-contents)
28  (or (get-param 'q header-contents) 1.0))
29
30;;;; Header parsers
31
32;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
33(define (split-multi-header value #!optional (parse? #t))
34  (let loop ((result '())
35             (start-pos 0))
36    (receive (str pos)
37      (read-token value start-pos (char-set #\,) parse?)
38      (if str
39          (loop (cons str result) (add1 pos))
40          (reverse result)))))
41
42;; This is ugly, it should be rewritten
43(define (read-token value start-pos stop-char-set #!optional (parse? #t))
44  (let ((length (string-length value))
45        (escaped? #f)
46        (in-string? #f))
47    (if (>= start-pos length)
48        (values #f start-pos)
49        (let loop ((start start-pos)
50                   (stop  start-pos)
51                   (str   ""))
52          (cond
53           ((= stop (sub1 length))
54            (values (string-append str
55                                   ((if in-string? identity string-trim-both)
56                                    (string-copy value start (if (and parse? in-string?)
57                                                                 (sub1 length)
58                                                                 length))))
59                    stop))
60           (escaped?
61            (set! escaped? #f)
62            (loop (add1 stop) (add1 stop)
63                  (string-append str (string-copy value stop (add1 stop)))))
64           ((and in-string? (char=? (string-ref value stop) #\\))
65            (set! escaped? #t)
66            (loop (add1 stop) (add1 stop)
67                  (string-append str
68                                 (string-copy value start stop)
69                                 (if parse? "" "\\"))))
70           ((char=? (string-ref value stop) #\")
71            (set! in-string? (not in-string?))
72            (loop (add1 stop) (add1 stop)
73                  (string-append
74                   (string-trim-both str)
75                   (if (not in-string?)
76                       (string-copy value start stop)
77                       (string-trim-both (string-copy value start stop)))
78                   (if (not parse?) "\"" ""))))
79           ((and (not in-string?)
80                 (char-set-contains? stop-char-set (string-ref value stop)))
81            (values (string-append
82                     str
83                     (string-trim-both (string-copy value start stop)))
84                    stop))
85           (else (loop start (add1 stop) str)))))))
86
87;; Just put all header strings in a list, so we can pass it on
88;; Make no assumptions about the contents (only value, don't try to parse params)
89;; This is different from (multiple (without-params generic-header-parser))
90;; because this does not assume it can split up comma-separated values
91(define (unknown-header-parser name contents headers)
92  (append-header-contents! name (list (make-value+params contents '())) headers))
93
94(define (read-tokens string start-pos . char-sets)
95  (let loop ((char-sets char-sets)
96             (start-pos start-pos)
97             (result    '()))
98    (if (null? char-sets)
99        (values (reverse result) start-pos)
100        (receive (str pos)
101                 (read-token string start-pos (car char-sets))
102                 (if str
103                     (loop (cdr char-sets) (add1 pos) (cons str result))
104                     (values (reverse result) pos))))))
105
106(define (read-parameters string start-pos param-parsers)
107  (let loop ((start-pos start-pos)
108             (params '()))
109    (receive (key pos)
110      (read-token string start-pos (char-set #\; #\=))
111      (if key
112          (if (char=? (string-ref string pos) #\=)
113              (receive (value pos)
114                (read-token string (add1 pos) (char-set #\;))
115                (let ((key (string->symbol (string-downcase key))))
116                  (if value
117                      (let ((value ((alist-ref key param-parsers eq? identity) value)))
118                        (loop (add1 pos) (cons (cons key value) params)))
119                      ;; "foo=" - use the empty string as value
120                      (values (reverse (cons (cons key "") params)) pos))))
121              ;; Missing value is interpreted as "present",
122              ;; so #t. If not present, it's #f when looking it up
123              (loop (add1 pos) (cons (cons (string->symbol key) #t) params)))
124          (values (reverse params) pos)))))
125
126(define (read-value+parameters string start-pos value-parser param-parsers)
127  (receive (value pos)
128    (read-token string start-pos (char-set #\;))
129    (if (not value)
130        (values #f pos)
131        (receive (params pos)
132          (read-parameters string (add1 pos) param-parsers)
133          (values (make-value+params (value-parser value) params)
134                  pos)))))
135
136(define (with-params value-parser parameter-parsers)
137  (lambda (entry)
138    (receive (type+params pos)
139      (read-value+parameters entry 0 value-parser parameter-parsers)
140      type+params)))
141
142(define (multiple other-parser #!optional (parameter-parsers '()))
143  (lambda (name entries headers)
144    (fold (lambda (entry headers)
145            (append-header-contents!
146             name
147             (list ((with-params other-parser parameter-parsers) entry))
148             headers))
149          headers
150          (split-multi-header entries #f))))
151
152(define (single other-parser #!optional (parameter-parsers '()))
153  (lambda (name contents headers)
154    (set-header-contents!
155     name
156     ((with-params other-parser parameter-parsers) contents)
157     headers)))
158
159(define (key/values key/value-parsers)
160  (lambda (k/v)
161    ;; We're abusing read-parameters here to read value
162    ;; instead of params.  This is weird, but it works :)
163    (receive (key+value pos)
164      (read-parameters k/v 0 key/value-parsers)
165      (car key+value))))
166
167(define symbol-parser-ci
168  (compose string->symbol string-trim-both string-downcase))
169
170(define symbol-parser
171  (compose string->symbol string-trim-both))
172
173(define (natnum-parser contents)
174  (let ((num (string->number contents)))
175    (if num (inexact->exact (max 0 (round num))) 0)))
176
177; base64 of 128 bit hex digest as per RFC1864
178(define md5-parser base64:decode)
179
180;; bytes <start>-<end>/<total>
181(define (range-parser s)
182  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
183            (map string->number (drop parts 1))))
184
185;; rfc1123-date | rfc850-date | asctime-date
186(define http-time-parser rfc822-time-parser)
187
188;; (W/)<string>
189(define (entity-tag-parser contents)
190  (if (string-prefix? "W/" contents)
191      `(weak . ,(string-drop contents 2))
192      `(strong . ,contents)))
193
194;; RFC822/1123 mailbox parser - just strings for now
195(define mailbox-parser identity)
196
197;; Either an entity-tag or a http-date
198(define if-range-parser identity)
199
200;; Either delta-seconds or RFC822 timestamp
201(define (retry-after-parser contents)
202  (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
203      (natnum-parser contents)
204      (rfc822-time-parser contents)))
205
206;; Tricky - see 2616 14.45
207(define via-parser identity)
208
209;; Tricky - see 2616 14.46
210(define warning-parser identity)
211
212(define (key/value-parser str)
213  (let ((idx (string-index str #\=)))
214    (cons (string-take str idx) (string-drop str (add1 idx)))))
215
216;; The 'expires' header defined by the Netscape cookie spec contains
217;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
218(define (old-style-cookie? cookie)
219  (not (not (string-search (regexp "^[^=\"]+=[^=\"]+[[:space:]]*;.*expires[[:space:]]*=" #f) cookie))))
220
221(define set-cookie-parser
222  (let ((param-parsers `((expires . ,rfc822-time-parser)
223                         (max-age . ,string->number)
224                         (version . ,string->number))))
225    (lambda (name contents headers)
226      (if (old-style-cookie? contents)
227          (append-header-contents!
228           name
229           (list ((with-params key/value-parser param-parsers) contents))
230           headers)
231          ((multiple key/value-parser param-parsers) name contents headers)))))
232
233(define cache-control-parser
234  (let ((splitter (lambda (str) ;; Is this correct?
235                    (map (compose string->symbol string-trim-both)
236                         (string-split str ",")))))
237    (multiple
238     (key/values `((max-age . ,natnum-parser)
239                   (s-maxage . ,natnum-parser)
240                   (max-stale . ,natnum-parser)
241                   (min-fresh . ,natnum-parser)
242                   (private . ,splitter)
243                   (no-cache . ,splitter))))))
244
245;; Join this with cache-control
246(define (expect-parser name value headers)
247  (set-header-contents! name (read-parameters value 0 `()) headers))
248
249;; This too
250(define (pragma-parser name value headers)
251  (set-header-contents! name (read-parameters value 0 `()) headers))
252
253;; This one includes q parser
254(define (te-parser name value headers)
255  (set-header-contents! name (read-parameters value 0 `((q . ,quality-parser))) headers))
256
257;; Cookie headers are also braindead: there can be several cookies in one header,
258;; separated by either commas or semicolons. The only way to distinguish a
259;; new cookie from a parameter of the current cookie is the dollar in front
260;; of all parameter names.
261;; Also, there's a $Version attribute that prepends all cookies, which is
262;; considered to apply to all cookies that follow.
263;;
264;; This code is a bit of a hack in the way it abuses read-parameters
265(define (cookie-parser name value headers)
266  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
267  (define (split-attribs pairs)
268    (span (lambda (pair)
269            (string-prefix? "$" (symbol->string (car pair))))
270          pairs))
271  (receive (params pos)
272    (read-parameters value 0 `(($version . ,string->number)
273                               ($port . ,string->number)))
274    (receive (global-attrs remaining)
275      (split-attribs params)
276      (let loop ((remaining remaining)
277                 (cookies '()))
278        (if (null? remaining)
279            (append-header-contents! name (reverse cookies) headers)
280            (let ((cookie (cons (symbol->string (caar remaining))
281                                (cdar remaining)))
282                  (params (cdr remaining)))
283              (receive (local-attrs rest)
284                (split-attribs params)
285                (let* ((all-attrs (append global-attrs local-attrs))
286                       (result (make-value+params
287                                cookie all-attrs)))
288                  (loop rest (cons result cookies))))))))))
Note: See TracBrowser for help on using the repository browser.