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

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

Simplify the parsers a bit, in preparation for comment parsing

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