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

Last change on this file since 11579 was 11579, checked in by sjamaan, 12 years ago

Add a bit of client code, no tests yet

File size: 12.5 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;;;; MAJOR TODOs
195;; RFC822/1123 mailbox parser - just strings for now
196(define mailbox-parser identity)
197
198;; Either an entity-tag or a http-date
199(define if-range-parser identity)
200
201;; Either delta-seconds or RFC822 timestamp
202(define (retry-after-parser contents)
203  (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
204      (natnum-parser contents)
205      (rfc822-time-parser contents)))
206
207;; Tricky - see 2616 14.45
208;; We probably shouldn't try to do too much parsing here
209(define via-parser (multiple identity))
210
211;; Tricky - see 2616 14.46
212(define warning-parser (multiple identity))
213;;;; END MAJOR TODOs
214
215(define (key/value-parser str)
216  (let ((idx (string-index str #\=)))
217    (cons (string-take str idx) (string-drop str (add1 idx)))))
218
219;; The 'expires' header defined by the Netscape cookie spec contains
220;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
221(define (old-style-cookie? cookie)
222  (not (not (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))))
223
224(define set-cookie-parser
225  (let ((param-parsers `((expires . ,rfc822-time-parser)
226                         (max-age . ,string->number)
227                         (version . ,string->number))))
228    (lambda (name contents headers)
229      (if (old-style-cookie? contents)
230          (append-header-contents!
231           name
232           (list ((with-params key/value-parser param-parsers) contents))
233           headers)
234          ((multiple key/value-parser param-parsers) name contents headers)))))
235
236(define cache-control-parser
237  (let ((splitter (lambda (str) ;; Is this correct?
238                    (map (compose string->symbol string-trim-both)
239                         (string-split str ",")))))
240    (multiple
241     (key/values `((max-age . ,natnum-parser)
242                   (s-maxage . ,natnum-parser)
243                   (max-stale . ,natnum-parser)
244                   (min-fresh . ,natnum-parser)
245                   (private . ,splitter)
246                   (no-cache . ,splitter))))))
247
248;; This too
249(define (pragma-parser name value headers)
250  (set-header-contents! name (read-parameters value 0 `()) headers))
251
252;; This one includes q parser
253(define (te-parser name value headers)
254  (set-header-contents! name (read-parameters value 0 `((q . ,quality-parser))) headers))
255
256;; Cookie headers are also braindead: there can be several cookies in one header,
257;; separated by either commas or semicolons. The only way to distinguish a
258;; new cookie from a parameter of the current cookie is the dollar in front
259;; of all parameter names.
260;; Also, there's a $Version attribute that prepends all cookies, which is
261;; considered to apply to all cookies that follow.
262;;
263;; This code is a bit of a hack in the way it abuses read-parameters
264(define (cookie-parser name value headers)
265  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
266  (define (split-attribs pairs)
267    (span (lambda (pair)
268            (string-prefix? "$" (symbol->string (car pair))))
269          pairs))
270  (receive (params pos)
271    (read-parameters value 0 `(($version . ,string->number)
272                               ($port . ,string->number)))
273    (receive (global-attrs remaining)
274      (split-attribs params)
275      (let loop ((remaining remaining)
276                 (cookies '()))
277        (if (null? remaining)
278            (append-header-contents! name (reverse cookies) headers)
279            (let ((cookie (cons (symbol->string (caar remaining))
280                                (cdar remaining)))
281                  (params (cdr remaining)))
282              (receive (local-attrs rest)
283                (split-attribs params)
284                (let* ((all-attrs (append global-attrs local-attrs))
285                       (result (make-value+params
286                                cookie all-attrs)))
287                  (loop rest (cons result cookies))))))))))
288
289;;; Unparsers ;;;
290(define (unparse-params params unparsers)
291  (let loop ((params params)
292             (result ""))
293    (if (null? params)
294        result
295        (let* ((unparser (alist-ref unparsers (caar params) eq?
296                                    (lambda (name value)
297                                      (conc name "=" value))))
298               (str (unparser (caar params) (cdar params))))
299          (loop (cdr params) (string-append result ";" str))))))
300
301(define (unparse-token token)
302  (if (string-any (char-set #\" #\; #\,) token)
303      (string-append "\"" (string-translate* token '(("\"" . "\\\"")
304                                                     ("\\" . "\\\\"))) "\"")
305      token))
306
307(define (default-header-unparser header-name header)
308  (let loop ((headers (if (pair? header) header (list header)))
309             (result ""))
310    (if (null? headers)
311        (sprintf "~A: ~A\r\n" header-name result) ; TODO: Camel-Case the header name
312        (let* ((contents (value+params-value (car headers)))
313               (value (if (pair? contents)
314                          (conc (car contents) "=" (cdr contents))
315                          (->string contents)))
316               (parameter-unparsers '())) ; Maybe we want to make this a param
317         (loop (cdr headers)
318               (string-append (unparse-token value)
319                              (unparse-params (value+params-params (car headers))
320                                              parameter-unparsers)))))))
321
Note: See TracBrowser for help on using the repository browser.