source: project/release/4/intarweb/trunk/intarweb.scm @ 11722

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

Remove value+params struct, normalize to vectors

File size: 11.9 KB
Line 
1;;
2;; Intarweb is an improved HTTP library for Chicken
3;;
4; Copyright (c) 2008, Peter Bex
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of the author nor the names of its
17;    contributors may be used to endorse or promote products derived
18;    from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32;
33; Please report bugs, suggestions and ideas to the Chicken Trac
34; ticket tracking system (assign tickets to user 'sjamaan'):
35; http://trac.callcc.org
36
37(require-library srfi-1 srfi-13 regex regex-case base64)
38
39(module intarweb
40  (read-line-limit replace-header-contents replace-header-contents!
41   update-header-contents update-header-contents! make-headers single-headers
42   string->header-name header-name->string header-parsers
43   http-0.9-request-parser http-1.x-request-parser
44   make-request request? request-major-version request-minor-version
45   request-method request-uri request-headers request-port
46   protocol-parsers read-request write-request read-headers
47   make-response response? response-major-version response-minor-version
48   response-code response-reason response-headers response-port
49   header-unparsers unparse-headers write-response read-response
50
51   ;; http-header-parsers
52   split-multi-header unknown-header-parser single multiple read-token
53   get-header-contents get-header-values
54   get-quality get-value get-params get-param header-list-ref
55   natnum-parser symbol-parser-ci symbol-parser
56   default-header-unparser
57   )
58
59  (import scheme chicken (except extras read-token) ports data-structures
60          srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:))
61
62(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
63
64(define (replace-header-contents! name contents headers)
65  (let loop ((h headers))
66    (cond
67     ((null? h) (cons (cons name contents) headers))
68     ((eq? name (caar h))
69      (set-cdr! (car h) contents)
70      headers)
71     (else (loop (cdr h))))))
72
73(define (replace-header-contents name contents headers)
74  (let loop ((h headers))
75    (cond
76     ((null? h) (cons (cons name contents) headers))
77     ((eq? name (caar h))
78      (cons (cons (caar h) contents) (cdr h)))
79     (else (cons (car h) (loop (cdr h)))))))
80
81(define (make-updater replacer)
82  (lambda (name contents headers)
83    (let ((old (get-header-contents name headers '())))
84      (replacer name
85                (if (member name (single-headers))
86                    (list (last contents))
87                    (append old contents))
88                headers))))
89
90(define update-header-contents  (make-updater replace-header-contents))
91(define update-header-contents! (make-updater replace-header-contents!))
92
93(define (string->header-name s) (string->symbol (string-downcase! s)))
94(define (header-name->string h) (string-titlecase (symbol->string h)))
95
96(define (make-headers headers-to-be #!optional (old-headers '()))
97  (fold (lambda (h new-headers)
98          (update-header-contents
99           (car h)
100           (map (lambda (v)
101                  (if (vector? v) v (vector v '()))) ; normalize to vector
102                (cdr h))
103           new-headers))
104        old-headers
105        headers-to-be))
106
107(include "../header-parsers")
108
109;; Any unknown headers are considered to be multi-headers, always
110(define single-headers
111  (make-parameter '(accept-ranges age authorization content-length
112                    content-location content-md5 content-type date etag
113                    expect expires host if-modified-since if-unmodified-since
114                    last-modified location max-forwards proxy-authorization
115                    range referer retry-after server transfer-encoding
116                    user-agent www-authenticate)))
117
118;; This includes parsers for all RFC-defined headers
119(define header-parsers
120  (make-parameter
121   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
122     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
123     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
124     (accept-ranges . ,(single symbol-parser-ci))
125     (age . ,(single natnum-parser))
126     (allow . ,(multiple symbol-parser))
127     (authorization . ,(single symbol-parser-ci))
128     (cache-control . ,cache-control-parser)
129     (connection . ,(multiple symbol-parser-ci))
130     (content-encoding . ,(multiple symbol-parser-ci))
131     (content-language . ,(multiple symbol-parser-ci))
132     (content-length . ,(single natnum-parser))
133     (content-location . ,(single identity))
134     (content-md5 . ,(single md5-parser))
135     (content-range . ,(single range-parser))
136     (content-type . ,(single symbol-parser-ci))
137     (date . ,(single http-time-parser))
138     (etag . ,(single entity-tag-parser))
139     (expect . ,(single key/values))
140     (expires . ,(single rfc822-time-parser))
141     (from . ,(multiple mailbox-parser))
142     (host . ,(single identity))
143     (if-match . ,(multiple entity-tag-parser))
144     (if-modified-since . ,(single rfc822-time-parser))
145     (if-none-match . ,(multiple entity-tag-parser))
146     (if-range . ,(multiple if-range-parser))
147     (if-unmodified-since . ,(single rfc822-time-parser))
148     (last-modified . ,(single rfc822-time-parser))
149     (location . ,(single identity))
150     (max-forwards . ,(single natnum-parser))
151     (pragma . ,pragma-parser)
152     (proxy-authenticate . ,(multiple symbol-parser-ci))
153     (proxy-authorization . ,(single symbol-parser-ci))
154     (range . ,range-parser)
155     (referer . ,(single identity))
156     (retry-after . ,retry-after-parser)
157     (server . ,(single identity))
158     (te . ,te-parser)
159     (trailer . ,(multiple symbol-parser-ci))
160     (transfer-encoding . ,(single symbol-parser-ci))
161     (upgrade . ,(multiple update-header-contents!))
162     (user-agent . ,(single identity))
163     (vary . ,(multiple symbol-parser-ci))
164     (via . ,via-parser)
165     (warning . ,warning-parser)
166     (www-authenticate . ,(single symbol-parser-ci))
167     ;; RFC 2109
168     (set-cookie . ,set-cookie-parser)
169     (cookie . ,cookie-parser)
170     ;; RFC 2965?
171     )))
172
173;; The parser is supposed to return the new (possibly modified) headers list
174(define (parse-header name contents headers)
175  (let* ((default unknown-header-parser)
176         (parser (alist-ref name (header-parsers) eq? default)))
177    (parser name contents headers)))
178
179(define (parse-header-line line headers)
180  (or
181   (and-let* ((colon-idx   (string-index line #\:))
182              (header-name (string->header-name (string-take line colon-idx)))
183              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
184             (parse-header header-name contents headers))
185   (signal-http-condition "Bad header line" 'header-error 'contents line)))
186
187(define (read-headers port)
188  (let ((first-line (read-line port)))
189    (if (or (eof-object? first-line) (string-null? first-line))
190        '()
191        (let loop ((prev-line first-line)
192                   (line      (read-line port))
193                   (headers   '()))
194          (if (or (eof-object? line) (string-null? line))
195              (if (string-null? prev-line)
196                  headers
197                  (parse-header-line prev-line headers))
198              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
199                  (loop (string-append prev-line line) (read-line port)
200                        headers)
201                  (loop line (read-line port)
202                        (parse-header-line prev-line headers))))))))
203
204(define (signal-http-condition msg type . more-info)
205  (signal (make-composite-condition
206           (make-property-condition 'http)
207           (apply make-property-condition type more-info)
208           (make-property-condition 'exn 'message msg))))
209
210(define-record request method uri major-version minor-version headers port)
211
212;; Perhaps we should have header parsers indexed by version or
213;; something like that, so you can define the maximum version. Useful
214;; for when expecting a response. Then we group request/response parsers
215;; together, as with request/response unparsers.
216(define (http-0.9-request-parser line in)
217  (regex-case line
218    ("[Gg][Ee][Tt] +([^ \t]+)"
219     (_ uri)
220     (make-request 'GET uri 0 9 '() in))
221    (else #f)))
222
223(define string->http-method string->symbol)
224(define http-method->string symbol->string)
225
226(define (http-1.x-request-parser line in)
227  (regex-case line
228   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
229    (_ method uri major minor)
230    (make-request (string->http-method method)
231                  uri (string->number major) (string->number minor)
232                  (read-headers in) in))
233   (else #f)))
234
235(define protocol-parsers   ; order matters here
236  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
237
238(define (read-request inport)
239  (let* ((line (read-line inport (read-line-limit)))
240         ;; A bit ugly, but simpler than the alternatives
241         (line (if (eof-object? line) "" line)))
242    ;; Try each parser in turn to process the request-line.
243    ;; A parser returns either #f or a request object
244    (let loop ((parsers (protocol-parsers)))
245      (if (null? parsers)
246          (signal-http-condition "Unknown protocol" 'unknown-protocol)
247          (or ((car parsers) line inport) (loop (cdr parsers)))))))
248
249;; TODO: Handle HTTP/0.9
250(define (write-request request)
251  (let ((o (request-port request)))
252    (fprintf o "~A ~A HTTP/~A.~A\r\n"
253             (request-method request)
254             (request-uri request)
255             (request-major-version request)
256             (request-minor-version request))
257    (unparse-headers (request-headers request) o)
258    (fprintf o "\r\n")))
259
260(define-record response code reason major-version minor-version headers port)
261
262(define header-unparsers
263  (make-parameter
264   `()))
265
266(define (unparse-headers headers out)
267  (for-each
268     (lambda (h)
269       (let* ((name (car h))
270              (contents (cdr h))
271              (def default-header-unparser)
272              (unparser (alist-ref name (header-unparsers) eq? def)))
273         (display (unparser name contents) out)))
274     headers))
275
276;; TODO: Handle HTTP/0.9
277(define (write-response response)
278  (let ((o (response-port response)))
279    (fprintf o "HTTP/~A.~A ~A ~A\r\n"
280             (response-major-version response)
281             (response-minor-version response)
282             (response-code response)
283             (response-reason response))
284    (unparse-headers (response-headers response) o)
285    (fprintf o "\r\n")))
286
287(define (http-1.x-response-parser line in)
288  (regex-case line
289   ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) ([0-9]{3}) +(.*)"
290    (_ major minor code reason)
291    (make-response (string->number code) reason
292                   (string->number major) (string->number minor)
293                   (read-headers in) in))
294   (else #f)))
295
296;; TODO: Handle HTTP/0.9
297(define (read-response inport)
298  (let* ((line (read-line inport (read-line-limit))))
299    (http-1.x-response-parser line inport)))
300
301)
Note: See TracBrowser for help on using the repository browser.