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

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

Minor tweaks

File size: 8.6 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   request-major-version request-minor-version request-version-string
45   request-method request-uri request-headers protocol-parsers
46   process-request read-headers
47
48   ;; http-header-parsers
49   split-multi-header unknown-header-parser single multiple
50   read-token get-quality get-param get-value get-values header-list-ref
51   natnum-parser symbol-parser-ci symbol-parser
52   value+params? value+params-value value+params-params
53   )
54
55  (import scheme chicken extras ports data-structures srfi-1 srfi-13 srfi-14
56          regex regex-case (prefix base64 base64:))
57
58(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
59
60(define (set-header-contents! name contents headers)
61  (let loop ((h headers))
62    (cond
63     ((null? h) (cons (cons name contents) headers))
64     ((header-name=? name (caar h))
65      (set-cdr! (car h) contents)
66      headers)
67     (else (loop (cdr h))))))
68
69(define (append-header-contents! name contents headers)
70  (let ((old (get-header-contents name headers)))
71    (if old
72        (set-header-contents! name (append old contents) headers)
73        (set-header-contents! name contents headers))))
74
75(define (string->header-name s) (string->symbol (string-downcase! s)))
76(define (header-name->string h) (symbol->string h))
77(define header-name=? eq?)
78
79(include "../header-parsers")
80
81;; This includes parsers for all RFC-defined headers
82(define header-parsers
83  (make-parameter
84   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
85     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
86     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
87     (accept-ranges . ,(single symbol-parser-ci))
88     (age . ,(single natnum-parser))
89     (allow . ,(multiple symbol-parser))
90     (authorization . ,(single symbol-parser-ci))
91     (cache-control . ,cache-control-parser)
92     (connection . ,(multiple symbol-parser-ci))
93     (content-encoding . ,(multiple symbol-parser-ci))
94     (content-language . ,(multiple symbol-parser-ci))
95     (content-length . ,(single natnum-parser))
96     (content-location . ,(single identity))
97     (content-md5 . ,(single md5-parser))
98     (content-range . ,(single range-parser))
99     (content-type . ,(single symbol-parser-ci))
100     (date . ,(single http-time-parser))
101     (etag . ,(single entity-tag-parser))
102     (expect . ,(single key/values))
103     (expires . ,(single rfc822-time-parser))
104     (from . ,(multiple mailbox-parser))
105     (host . ,(single identity))
106     (if-match . ,(multiple entity-tag-parser))
107     (if-modified-since . ,rfc822-time-parser)
108     (if-none-match . ,(multiple entity-tag-parser))
109     (if-range . ,(multiple if-range-parser))
110     (if-unmodified-since . ,rfc822-time-parser)
111     (last-modified . ,rfc822-time-parser)
112     (location . ,(single identity))
113     (max-forwards . ,natnum-parser)
114     (pragma . ,pragma-parser)
115     (proxy-authenticate . ,(multiple symbol-parser-ci))
116     (proxy-authorization . ,(single symbol-parser-ci))
117     (range . ,range-parser)
118     (referer . ,(single identity))
119     (retry-after . ,retry-after-parser)
120     (server . ,(single identity))
121     (te . ,te-parser)
122     (trailer . ,(multiple symbol-parser-ci))
123     (transfer-encoding . ,(single symbol-parser-ci))
124     (upgrade . ,(multiple append-header-contents!))
125     (user-agent . ,(single identity))
126     (vary . ,(multiple symbol-parser-ci))
127     (via . ,via-parser)
128     (warning . ,warning-parser)
129     (www-authenticate . ,(single symbol-parser-ci))
130     ;; RFC 2109
131     (set-cookie . ,set-cookie-parser)
132     (cookie . ,cookie-parser)
133     ;; RFC 2965?
134     )))
135
136(define (get-header-contents name headers)
137  (alist-ref name headers header-name=?))
138
139;; The parser is supposed to return the new (possibly modified) headers list
140(define (parse-header name contents headers)
141  (let* ((default unknown-header-parser)
142         (parser (alist-ref name (header-parsers) header-name=? default)))
143    (parser name contents headers)))
144
145(define (parse-header-line line headers)
146  (or
147   (and-let* ((colon-idx   (string-index line #\:))
148              (header-name (string->header-name (string-take line colon-idx)))
149              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
150             (parse-header header-name contents headers))
151   (signal-http-condition "Bad header line" 'header-error 'contents line)))
152
153(define (read-headers port)
154  (let ((first-line (read-line port)))
155    (if (or (eof-object? first-line) (string-null? first-line))
156        '()
157        (let loop ((prev-line first-line)
158                   (line      (read-line port))
159                   (headers   '()))
160          (if (or (eof-object? line) (string-null? line))
161              (if (string-null? prev-line)
162                  headers
163                  (parse-header-line prev-line headers))
164              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
165                  (loop (string-append prev-line line) (read-line port)
166                        headers)
167                  (loop line (read-line port)
168                        (parse-header-line prev-line headers))))))))
169
170(define (signal-http-condition msg type . more-info)
171  (signal (make-composite-condition
172           (make-property-condition 'http)
173           (apply make-property-condition type more-info)
174           (make-property-condition 'exn 'message msg))))
175
176(define-record request method uri major-version minor-version headers inport outport)
177
178;; We can't store the version as an inexact, because version 1.10 <> 1.1
179(define (request-version-string req)
180  (sprintf "~A.~A" (request-major-version req) (request-minor-version req)))
181
182(define (http-0.9-request-parser line in out)
183  (regex-case line
184    ("[Gg][Ee][Tt] +([^ \t]+)"
185     (_ uri)
186     (make-request 'GET uri 0 9 '() in out))
187    (else #f)))
188
189(define string->http-method string->symbol)
190(define http-method->string symbol->string)
191
192(define (http-1.x-request-parser line in out)
193  (regex-case line
194   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
195    (_ method uri major minor)
196    (make-request (string->http-method method)
197                  uri (string->number major) (string->number minor)
198                  (read-headers in) in out))
199   (else #f)))
200
201(define protocol-parsers   ; order matters here
202  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
203
204(define (process-request inport outport)
205  (let ((line (read-line inport (read-line-limit))))
206    ; Try each parser in turn to process the request-line.
207    ; A parser returns either #f or a request object
208    (let loop ((parsers (protocol-parsers)))
209      (if (null? parsers)
210          (signal-http-condition "Unknown protocol" 'unknown-protocol)
211          (or ((car parsers) line inport outport) (loop (cdr parsers)))))))
212)
Note: See TracBrowser for help on using the repository browser.