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

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

Allow spaces and tabs in unparsed tokens too by quoting them

File size: 14.2 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;; Get the raw contents of a header
17(define (header-contents name headers #!optional (default #f))
18  (alist-ref name headers eq? default))
19
20;; Get all values of a header
21(define (header-values header-name headers)
22  (map (cut vector-ref <> 0) (header-contents header-name headers '())))
23
24;; Get the value of a header which is an alist
25;; Example: header = ((foo . bar) (qux . mooh)), header-list-ref foo
26;; will return bar.  (the header itself is encoded in a param+value
27(define (header-list-ref value headers #!optional (equal? eq?))
28  (find (lambda (h) (equal? (car (get-value h)) value)) headers))
29
30;; Get the value from one header entry
31(define get-value (cut vector-ref <> 0))
32
33;; Get all params from one header entry
34(define get-params (cut vector-ref <> 1))
35
36;; Get one specific parameter from one header entry
37(define (get-param param contents)
38  (alist-ref param (vector-ref contents 1) eq?))
39
40;; Get-param, except if no quality is present return 1
41(define (get-quality header-contents)
42  (or (get-param 'q header-contents) 1.0))
43
44;;;; Header parsers
45
46;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
47(define (split-multi-header value #!optional (parse? #t))
48  (let loop ((result '())
49             (start-pos 0))
50    (receive (str pos)
51      (read-token value start-pos (char-set #\,) parse?)
52      (if str
53          (loop (cons str result) (add1 pos))
54          (reverse result)))))
55
56;; This is ugly, it should be rewritten
57(define (read-token value start-pos stop-char-set #!optional (parse? #t))
58  (let ((length (string-length value))
59        (escaped? #f)
60        (in-string? #f))
61    (if (>= start-pos length)
62        (values #f start-pos)
63        (let loop ((start start-pos)
64                   (stop  start-pos)
65                   (str   ""))
66          (cond
67           ((= stop (sub1 length))
68            (values (string-append str
69                                   ((if in-string? identity string-trim-both)
70                                    (string-copy value start (if (and parse? in-string?)
71                                                                 (sub1 length)
72                                                                 length))))
73                    stop))
74           (escaped?
75            (set! escaped? #f)
76            (loop (add1 stop) (add1 stop)
77                  (string-append str (string-copy value stop (add1 stop)))))
78           ((and in-string? (char=? (string-ref value stop) #\\))
79            (set! escaped? #t)
80            (loop (add1 stop) (add1 stop)
81                  (string-append str
82                                 (string-copy value start stop)
83                                 (if parse? "" "\\"))))
84           ((char=? (string-ref value stop) #\")
85            (set! in-string? (not in-string?))
86            (loop (add1 stop) (add1 stop)
87                  (string-append
88                   (string-trim-both str)
89                   (if (not in-string?)
90                       (string-copy value start stop)
91                       (string-trim-both (string-copy value start stop)))
92                   (if (not parse?) "\"" ""))))
93           ((and (not in-string?)
94                 (char-set-contains? stop-char-set (string-ref value stop)))
95            (values (string-append
96                     str
97                     (string-trim-both (string-copy value start stop)))
98                    stop))
99           (else (loop start (add1 stop) str)))))))
100
101;; Just put all header strings in a list, so we can pass it on
102;; Make no assumptions about the contents (only value, don't try to parse params)
103;; This is different from (multiple (without-params generic-header-parser))
104;; because this does not assume it can split up comma-separated values
105(define (unknown-header-parser name contents headers)
106  (update-header-contents! name (list (vector contents '())) headers))
107
108(define (read-tokens string start-pos . char-sets)
109  (let loop ((char-sets char-sets)
110             (start-pos start-pos)
111             (result    '()))
112    (if (null? char-sets)
113        (values (reverse result) start-pos)
114        (receive (str pos)
115                 (read-token string start-pos (car char-sets))
116                 (if str
117                     (loop (cdr char-sets) (add1 pos) (cons str result))
118                     (values (reverse result) pos))))))
119
120(define (read-parameters string start-pos param-parsers)
121  (let loop ((start-pos start-pos)
122             (params '()))
123    (receive (key pos)
124      (read-token string start-pos (char-set #\; #\=))
125      (if key
126          (if (char=? (string-ref string pos) #\=)
127              (receive (value pos)
128                (read-token string (add1 pos) (char-set #\;))
129                (let ((key (string->symbol (string-downcase key))))
130                  (if value
131                      (let ((value ((alist-ref key param-parsers eq? identity) value)))
132                        (loop (add1 pos) (cons (cons key value) params)))
133                      ;; "foo=" - use the empty string as value
134                      (values (reverse (cons (cons key "") params)) pos))))
135              ;; Missing value is interpreted as "present",
136              ;; so #t. If not present, it's #f when looking it up
137              (loop (add1 pos) (cons (cons (string->symbol key) #t) params)))
138          (values (reverse params) pos)))))
139
140(define (read-value+parameters string start-pos value-parser param-parsers)
141  (receive (value pos)
142    (read-token string start-pos (char-set #\;))
143    (if (not value)
144        (values #f pos)
145        (receive (params pos)
146          (read-parameters string (add1 pos) param-parsers)
147          (values (vector (value-parser value) params) pos)))))
148
149(define (with-params value-parser parameter-parsers)
150  (lambda (entry)
151    (receive (type+params pos)
152      (read-value+parameters entry 0 value-parser parameter-parsers)
153      type+params)))
154
155(define (multiple other-parser #!optional (parameter-parsers '()))
156  (lambda (name entries headers)
157    (fold (lambda (entry headers)
158            (update-header-contents!
159             name
160             (list ((with-params other-parser parameter-parsers) entry))
161             headers))
162          headers
163          (split-multi-header entries #f))))
164
165(define (single other-parser #!optional (parameter-parsers '()))
166  (lambda (name contents headers)
167    (replace-header-contents!
168     name
169     (list ((with-params other-parser parameter-parsers) contents))
170     headers)))
171
172(define (key/values key/value-parsers)
173  (lambda (k/v)
174    ;; We're abusing read-parameters here to read value
175    ;; instead of params.  This is weird, but it works :)
176    (receive (key+value pos)
177      (read-parameters k/v 0 key/value-parsers)
178      (car key+value))))
179
180(define symbol-parser-ci
181  (compose string->symbol string-trim-both string-downcase))
182
183(define symbol-parser
184  (compose string->symbol string-trim-both))
185
186(define (natnum-parser contents)
187  (let ((num (string->number contents)))
188    (if num (inexact->exact (max 0 (round num))) 0)))
189
190; base64 of 128 bit hex digest as per RFC1864
191(define md5-parser base64:decode)
192
193;; bytes <start>-<end>/<total>
194(define (range-parser s)
195  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
196            (map string->number (drop parts 1))))
197
198;; rfc1123-date | rfc850-date | asctime-date
199(define http-time-parser rfc822-time-parser)
200
201;; (W/)<string>
202(define (entity-tag-parser contents)
203  (if (string-prefix? "W/" contents)
204      `(weak . ,(string-drop contents 2))
205      `(strong . ,contents)))
206
207;;;; MAJOR TODOs
208;; RFC822/1123 mailbox parser - just strings for now
209(define mailbox-parser identity)
210
211;; Either an entity-tag or a http-date
212(define if-range-parser identity)
213
214;; Either delta-seconds or RFC822 timestamp
215(define (retry-after-parser contents)
216  (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
217      (natnum-parser contents)
218      (rfc822-time-parser contents)))
219
220;; Tricky - see 2616 14.45
221;; We probably shouldn't try to do too much parsing here
222(define via-parser (multiple identity))
223
224;; Tricky - see 2616 14.46
225(define warning-parser (multiple identity))
226;;;; END MAJOR TODOs
227
228(define (key/value-parser str)
229  (let ((idx (string-index str #\=)))
230    (cons (string-take str idx) (string-drop str (add1 idx)))))
231
232;; The 'expires' header defined by the Netscape cookie spec contains
233;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
234(define (old-style-cookie? cookie)
235  (not (not (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))))
236
237(define set-cookie-parser
238  (let ((param-parsers `((expires . ,rfc822-time-parser)
239                         (max-age . ,string->number)
240                         (version . ,string->number))))
241    (lambda (name contents headers)
242      (if (old-style-cookie? contents)
243          (update-header-contents!
244           name
245           (list ((with-params key/value-parser param-parsers) contents))
246           headers)
247          ((multiple key/value-parser param-parsers) name contents headers)))))
248
249(define cache-control-parser
250  (let ((splitter (lambda (str) ;; Is this correct?
251                    (map (compose string->symbol string-trim-both)
252                         (string-split str ",")))))
253    (multiple
254     (key/values `((max-age . ,natnum-parser)
255                   (s-maxage . ,natnum-parser)
256                   (max-stale . ,natnum-parser)
257                   (min-fresh . ,natnum-parser)
258                   (private . ,splitter)
259                   (no-cache . ,splitter))))))
260
261;; This too
262(define (pragma-parser name value headers)
263  (update-header-contents! name (read-parameters value 0 `()) headers))
264
265;; This one includes q parser
266(define (te-parser name value headers)
267  (update-header-contents! name (read-parameters value 0 `((q . ,quality-parser))) headers))
268
269;; Cookie headers are also braindead: there can be several cookies in one header,
270;; separated by either commas or semicolons. The only way to distinguish a
271;; new cookie from a parameter of the current cookie is the dollar in front
272;; of all parameter names.
273;; Also, there's a $Version attribute that prepends all cookies, which is
274;; considered to apply to all cookies that follow.
275;;
276;; This code is a bit of a hack in the way it abuses read-parameters
277(define (cookie-parser name value headers)
278  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
279  (define (split-attribs pairs)
280    (span (lambda (pair)
281            (string-prefix? "$" (symbol->string (car pair))))
282          pairs))
283  (receive (params pos)
284    (read-parameters value 0 `(($version . ,string->number)
285                               ($port . ,string->number)))
286    (receive (global-attrs remaining)
287      (split-attribs params)
288      (let loop ((remaining remaining)
289                 (cookies '()))
290        (if (null? remaining)
291            (update-header-contents! name (reverse cookies) headers)
292            (let ((cookie (cons (symbol->string (caar remaining))
293                                (cdar remaining)))
294                  (params (cdr remaining)))
295              (receive (local-attrs rest)
296                (split-attribs params)
297                (let* ((all-attrs (append global-attrs local-attrs))
298                       (result (vector cookie all-attrs)))
299                  (loop rest (cons result cookies))))))))))
300
301;;; Unparsers ;;;
302(define (unparse-params params unparsers)
303  (let loop ((params params)
304             (results '()))
305    (if (null? params)
306        (string-join (reverse results) "; " 'prefix)
307        (let* ((unparser (alist-ref unparsers (caar params) eq?
308                                    (lambda (name value)
309                                      (case value
310                                        ;; #t means param is present (no value)
311                                        ((#t) (->string name))
312                                        ;; #f means param is missing
313                                        ((#f) #f)
314                                        (else (conc name "=" value))))))
315               (str (unparser (caar params) (cdar params))))
316          (loop (cdr params) (if str (cons str results) results))))))
317
318(define unparse-token
319  (let* ((must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
320         (trigger-quoting-chars (char-set-union
321                                 (char-set-adjoin must-be-quoted-chars #\, #\;)
322                                 char-set:blank))
323         (smap (map (lambda (c)
324                      (cons (string c)
325                            (string-append "\\" (string c))))
326                    (char-set->list must-be-quoted-chars))))
327   (lambda (token)
328     (if (string-any trigger-quoting-chars token)
329         (string-append "\"" (string-translate* token smap) "\"")
330         token))))
331
332;; There's no need to make a specific header unparser for every header type.
333;; Usually, the Scheme value representing a header can unambiguously be
334;; unparsed into a header just by checking its type.
335(define (default-header-unparser header-name header-contents)
336  (let loop ((headers (reverse header-contents))
337             (result '()))
338    (if (null? headers)
339        (sprintf "~A: ~A\r\n"
340                 (header-name->string header-name)
341                 (string-join result ", "))
342        (let* ((contents (get-value (car headers)))
343               (value (cond
344                       ((pair? contents) ; alist?
345                        ;; XXX Do something with =, comma, semicolon and newline
346                        (if (eq? (cdr contents) #t)
347                            (->string (car contents))
348                            (conc (car contents) "=" (cdr contents))))
349                       ((uri? contents) (uri->string contents))
350                       (else (->string contents))))
351               (parameter-unparsers '())) ; Maybe we want to make this a param
352         (loop (cdr headers)
353               (cons
354                (string-append
355                 (unparse-token value)
356                 (unparse-params (get-params (car headers))
357                                 parameter-unparsers))
358                result))))))
Note: See TracBrowser for help on using the repository browser.