source: project/release/4/intarweb/trunk/intarweb.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: 10.7 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 set-header-contents! append-header-contents!
41   string->header-name header-name->string header-name=?
42   header-parsers get-header-contents
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 write-response read-response
50
51   ;; http-header-parsers
52   split-multi-header unknown-header-parser single multiple
53   read-token get-quality get-param get-value get-values header-list-ref
54   natnum-parser symbol-parser-ci symbol-parser
55   make-value+params value+params? value+params-value value+params-params
56   default-header-unparser
57   )
58
59  (import scheme chicken extras ports data-structures srfi-1 srfi-13 srfi-14
60          regex regex-case (prefix base64 base64:))
61
62(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
63
64(define (set-header-contents! name contents headers)
65  (let loop ((h headers))
66    (cond
67     ((null? h) (cons (cons name contents) headers))
68     ((header-name=? name (caar h))
69      (set-cdr! (car h) contents)
70      headers)
71     (else (loop (cdr h))))))
72
73(define (append-header-contents! name contents headers)
74  (let ((old (get-header-contents name headers)))
75    (if old
76        (set-header-contents! name (append old contents) headers)
77        (set-header-contents! name contents headers))))
78
79(define (string->header-name s) (string->symbol (string-downcase! s)))
80(define (header-name->string h) (symbol->string h))
81(define header-name=? eq?)
82
83(include "../header-parsers")
84
85;; This includes parsers for all RFC-defined headers
86(define header-parsers
87  (make-parameter
88   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
89     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
90     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
91     (accept-ranges . ,(single symbol-parser-ci))
92     (age . ,(single natnum-parser))
93     (allow . ,(multiple symbol-parser))
94     (authorization . ,(single symbol-parser-ci))
95     (cache-control . ,cache-control-parser)
96     (connection . ,(multiple symbol-parser-ci))
97     (content-encoding . ,(multiple symbol-parser-ci))
98     (content-language . ,(multiple symbol-parser-ci))
99     (content-length . ,(single natnum-parser))
100     (content-location . ,(single identity))
101     (content-md5 . ,(single md5-parser))
102     (content-range . ,(single range-parser))
103     (content-type . ,(single symbol-parser-ci))
104     (date . ,(single http-time-parser))
105     (etag . ,(single entity-tag-parser))
106     (expect . ,(single key/values))
107     (expires . ,(single rfc822-time-parser))
108     (from . ,(multiple mailbox-parser))
109     (host . ,(single identity))
110     (if-match . ,(multiple entity-tag-parser))
111     (if-modified-since . ,rfc822-time-parser)
112     (if-none-match . ,(multiple entity-tag-parser))
113     (if-range . ,(multiple if-range-parser))
114     (if-unmodified-since . ,rfc822-time-parser)
115     (last-modified . ,rfc822-time-parser)
116     (location . ,(single identity))
117     (max-forwards . ,natnum-parser)
118     (pragma . ,pragma-parser)
119     (proxy-authenticate . ,(multiple symbol-parser-ci))
120     (proxy-authorization . ,(single symbol-parser-ci))
121     (range . ,range-parser)
122     (referer . ,(single identity))
123     (retry-after . ,retry-after-parser)
124     (server . ,(single identity))
125     (te . ,te-parser)
126     (trailer . ,(multiple symbol-parser-ci))
127     (transfer-encoding . ,(single symbol-parser-ci))
128     (upgrade . ,(multiple append-header-contents!))
129     (user-agent . ,(single identity))
130     (vary . ,(multiple symbol-parser-ci))
131     (via . ,via-parser)
132     (warning . ,warning-parser)
133     (www-authenticate . ,(single symbol-parser-ci))
134     ;; RFC 2109
135     (set-cookie . ,set-cookie-parser)
136     (cookie . ,cookie-parser)
137     ;; RFC 2965?
138     )))
139
140(define (get-header-contents name headers)
141  (alist-ref name headers header-name=?))
142
143;; The parser is supposed to return the new (possibly modified) headers list
144(define (parse-header name contents headers)
145  (let* ((default unknown-header-parser)
146         (parser (alist-ref name (header-parsers) header-name=? default)))
147    (parser name contents headers)))
148
149(define (parse-header-line line headers)
150  (or
151   (and-let* ((colon-idx   (string-index line #\:))
152              (header-name (string->header-name (string-take line colon-idx)))
153              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
154             (parse-header header-name contents headers))
155   (signal-http-condition "Bad header line" 'header-error 'contents line)))
156
157(define (read-headers port)
158  (let ((first-line (read-line port)))
159    (if (or (eof-object? first-line) (string-null? first-line))
160        '()
161        (let loop ((prev-line first-line)
162                   (line      (read-line port))
163                   (headers   '()))
164          (if (or (eof-object? line) (string-null? line))
165              (if (string-null? prev-line)
166                  headers
167                  (parse-header-line prev-line headers))
168              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
169                  (loop (string-append prev-line line) (read-line port)
170                        headers)
171                  (loop line (read-line port)
172                        (parse-header-line prev-line headers))))))))
173
174(define (signal-http-condition msg type . more-info)
175  (signal (make-composite-condition
176           (make-property-condition 'http)
177           (apply make-property-condition type more-info)
178           (make-property-condition 'exn 'message msg))))
179
180(define-record request method uri major-version minor-version headers port)
181
182;; Perhaps we should have header parsers indexed by version or
183;; something like that, so you can define the maximum version. Useful
184;; for when expecting a response. Then we group request/response parsers
185;; together, as with request/response unparsers.
186(define (http-0.9-request-parser line in)
187  (regex-case line
188    ("[Gg][Ee][Tt] +([^ \t]+)"
189     (_ uri)
190     (make-request 'GET uri 0 9 '() in))
191    (else #f)))
192
193(define string->http-method string->symbol)
194(define http-method->string symbol->string)
195
196(define (http-1.x-request-parser line in)
197  (regex-case line
198   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
199    (_ method uri major minor)
200    (make-request (string->http-method method)
201                  uri (string->number major) (string->number minor)
202                  (read-headers in) in))
203   (else #f)))
204
205(define protocol-parsers   ; order matters here
206  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
207
208(define (read-request inport)
209  (let ((line (read-line inport (read-line-limit))))
210    ; Try each parser in turn to process the request-line.
211    ; A parser returns either #f or a request object
212    (let loop ((parsers (protocol-parsers)))
213      (if (null? parsers)
214          (signal-http-condition "Unknown protocol" 'unknown-protocol)
215          (or ((car parsers) line inport) (loop (cdr parsers)))))))
216
217;; TODO: Handle HTTP/0.9
218(define (write-request request)
219  (let ((o (request-port request)))
220    (fprintf o "~A ~A HTTP/~A.~A\r\n"
221             (request-method request)
222             (request-uri request)
223             (request-major-version request)
224             (request-minor-version request))
225    (for-each
226     (lambda (h)
227       (let* ((name (car h))
228              (contents (cdr h))
229              (def default-header-unparser)
230              (unparser (alist-ref name (header-unparsers) header-name=? def)))
231         (display (unparser name contents) o)))
232     (request-headers request))
233    (fprintf o "\r\n")))
234
235(define-record response code reason major-version minor-version headers port)
236
237(define header-unparsers
238  (make-parameter
239   `()))
240
241;; TODO: Handle HTTP/0.9
242(define (write-response response)
243  (let ((o (response-port response)))
244    (fprintf o "HTTP/~A.~A ~A ~A\r\n"
245             (response-major-version response)
246             (response-minor-version response)
247             (response-code response)
248             (response-reason response))
249    (for-each
250     (lambda (h)
251       (let* ((name (car h))
252              (contents (cdr h))
253              (def default-header-unparser)
254              (unparser (alist-ref name (header-unparsers) header-name=? def)))
255         (display (unparser name contents) o)))
256     (response-headers response))
257    (fprintf o "\r\n")))
258
259(define (http-1.x-response-parser line in)
260  (regex-case line
261   ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) ([0-9]{3}) +(.*)"
262    (_ major minor code reason)
263    (make-response (string->number code) reason
264                   (string->number major) (string->number minor)
265                   (read-headers in) in))
266   (else #f)))
267
268;; TODO: Handle HTTP/0.9
269(define (read-response inport)
270  (let* ((line (read-line inport (read-line-limit))))
271    (http-1.x-response-parser line inport)))
272
273)
Note: See TracBrowser for help on using the repository browser.