source: project/release/3/http/trunk/http-server.scm @ 8431

Last change on this file since 8431 was 8431, checked in by elf, 13 years ago

finished the fix, and fixed a dangled paren. my fault.

File size: 14.2 KB
Line 
1;;;; http-server.scm - Server API - felix
2;
3; Copyright (c) 2000-2005, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(declare
37  (fixnum)
38  ;(no-bound-checks)
39  (export 
40   http:make-server
41   http:add-resource
42   http:find-resource
43   http:remove-resource
44   http:content-parser 
45   http:request-method-handler 
46   http:fallback-handler
47   http:write-response-header 
48   http:write-error-response
49   http:request-count-limit
50   http:startup-hook
51   http:error-hook
52   http:log-hook
53   http:listen-procedure
54   http:accept-procedure
55   http:get-addresses-procedure
56   http:hard-close-procedure
57   http:url-transformation
58   http:current-request-count
59   http:force-close
60   http:error-response-handler) )
61
62(declare (uses extras srfi-1 srfi-13 srfi-18 tcp regex))
63
64(require-for-syntax 'regex-case)
65(use http-utils)
66
67
68;;; Constants:
69
70(define-constant default-request-count-limit 10000)
71
72
73;;; Helper routines:
74
75(define debugging #f)
76
77(define (dribble fstr . args)
78  (when debugging
79    (fprintf (current-error-port) "[~?]~%~!" fstr args) ) )
80
81(define (string->canonicalized-symbol str)
82  (string->symbol (string-upcase str)) )
83
84(define (protocol->string p)
85  (if p
86      (string-upcase (symbol->string p))
87      "HTTP/1.1") )
88
89(define exn-message (condition-property-accessor 'exn 'message))
90(define exn-arguments (condition-property-accessor 'exn 'arguments))
91(define exn-location (condition-property-accessor 'exn 'location))
92(define http:request-count-limit (make-parameter default-request-count-limit))
93(define current-number-of-threads 0)
94(define http:url-transformation (make-parameter identity))
95(define http:listen-procedure (make-parameter tcp-listen))
96(define http:accept-procedure (make-parameter tcp-accept))
97(define http:get-addresses-procedure (make-parameter tcp-addresses))
98(define http:hard-close-procedure (make-parameter tcp-abandon-port))
99
100(define http:error-hook
101  (make-parameter 
102   (lambda (ex)
103     (##sys#with-print-length-limit
104      256
105      (lambda ()
106        (fprintf (current-error-port)
107                 "thread ~A terminated with exception: ~A: ~S~A~%"
108                 (thread-name (current-thread))
109                 (exn-message ex) (exn-arguments ex) 
110                 (let ([loc (exn-location ex)])
111                   (if loc (sprintf " (~S)" loc) "") ) ) ) ) ) ) )
112
113(define (thread-fork thunk)
114  (set! current-number-of-threads (fx+ 1 current-number-of-threads))
115  (thread-start!
116   (make-thread
117    (lambda ()
118      (handle-exceptions ex ((http:error-hook) ex) (thunk))
119      (set! current-number-of-threads (fx- current-number-of-threads 1)) ) ) ) )
120
121(define current-server-protocol #f)
122(define current-server-name #f)
123(define current-server-port #f)
124(define request-count 0)
125
126(define http:startup-hook (make-parameter (constantly #f)))
127(define http:force-close (make-parameter #f))
128
129(define (http:current-request-count) request-count)
130
131
132
133;;; Create server:
134
135(define (http:make-server port #!key
136                          [name "ChickenRulesOK"]
137                          [protocol #f] 
138                          [init noop]
139                          [accept #f] 
140                          [backlog 40] )
141  (lambda dbg
142    (let ([dbgmode (:optional dbg #f)])
143      (fluid-let ([debugging (eq? dbgmode #t)]
144                  [current-server-protocol protocol] 
145                  [current-server-name name]
146                  [current-server-port port] )
147        (dribble "waiting for requests...")
148        ((http:startup-hook))
149        (let ([listener ((http:listen-procedure) current-server-port backlog accept)])
150          (define (serve)
151            (let-values ([(in out)
152                          (handle-exceptions exn
153                              (begin (print-error-message exn (current-error-port))
154                                     (values #f #f) )
155                            ((http:accept-procedure) listener)) ] )
156              (when in
157                (thread-fork
158                 (lambda ()
159                   (let ([id (thread-name (current-thread))])
160                     (let-values ([(_ you) ((http:get-addresses-procedure) in)])
161                       (dribble "request ~A from ~A; ~A (of ~A) started..." 
162                                request-count you id current-number-of-threads)
163                       (let loop ()
164                         (set! request-count (add1 request-count))
165                         (dispatch-request
166                          in out you
167                          (lambda (k)
168                            (if k
169                                (begin
170                                  (dribble "~A (of ~A) kept alive, reading next request..." 
171                                           id current-number-of-threads)
172                                  (loop) )
173                                (dribble "~A finished." id) ) ) ) ) ) ) ) ) ) ) )
174          (init)
175          (let loop ()
176            (if (< current-number-of-threads (http:request-count-limit))
177                (serve)
178                (thread-yield!) )
179            (loop) ) ) ) ) ) )
180
181(define content-parsers (make-hash-table))
182
183(define (dispatch-request in out addr kont)
184  (handle-exceptions ex
185      (begin
186        (hard-close in out)
187        (signal ex) )
188    (let ([req (read-request in out addr)])
189      (when req
190        (handle-request req in out) )
191      (kont (complete-request req in out addr) ) ) ) )
192
193(define (complete-request req in out addr)
194  ((http:log-hook) req addr)
195  (or (and req (not (http:force-close)) (keep-alive? req))
196      (begin
197        (close-connection in out) 
198        #f) ) )
199
200(define http:log-hook (make-parameter noop))
201
202(define (keep-alive? req)
203  (let ([con (lookup-request-attribute "connection" (http:request-attributes req))]
204        [http11 (eq? 'HTTP/1.1 (http:request-protocol req))] )
205    (if con
206        (or (string-ci=? con "keep-alive")
207            (and http11
208                 (not (string-ci=? con "close")) ) )
209        http11) ) )
210
211(define (close-connection in out)
212  (dribble "closing connection...")
213  (close-output-port out)
214  (close-input-port in) )
215
216(define (hard-close in out)
217  ((http:hard-close-procedure) in)
218  ((http:hard-close-procedure) out)
219  (close-input-port in)
220  (close-output-port out) )
221
222(define (read-line-perhaps in)
223  (handle-exceptions _ #!eof
224    (read-line in (http:read-line-limit)) ) )
225
226(define (read-request in out ip)
227  (let ([ln (read-line-perhaps in)])
228    (if (eof-object? ln)
229        (begin
230          (dribble "client closed connection or read timed out.")
231          #f)
232        (begin
233          (dribble "read: ~S" ln)
234          (match (and (not (eof-object? ln)) (string-split ln))
235            [(method url protocol)
236             (dribble "request: method=~A, url=~A, protocol=~A" method url protocol)
237             (let* ([p (string->canonicalized-symbol protocol)]
238                    [urw (http:url-transformation)]
239                    [url (urw url)]
240                    [sp current-server-protocol] )
241               (cond [(and sp (not (eq? p sp)))
242                      (http:write-unsupported-protocol-response out) 
243                      #f]
244                     [(http:read-request-attributes in) =>
245                      (lambda (attrs)
246                        (dribble "attributes: ~S" attrs) 
247                        (let-values (((b ub) 
248                                      (let ([ct (find-content-type attrs)])
249                                        (if ct
250                                            ((find-content-parser (string->symbol ct))
251                                             (let ([a (lookup-request-attribute "content-length" attrs)])
252                                               (and a (string->number a)) )
253                                             attrs
254                                             in)
255                                            (values '() "") ) ) ) )
256                          (http:make-request
257                           (string->canonicalized-symbol method)
258                           (regex-case url
259                             ["http://(.+)" (_ url) url]
260                             [else url] )
261                           attrs
262                           b ub
263                           p ip) ) ) ]
264                     [else (dribble "No request attributes") (http:write-bad-request-response out) #f] ) ) ]
265            [_ (dribble "Bad request line") (http:write-bad-request-response out) #f] ) ) ) ) )
266
267(define (find-content-type attrs)
268  (and-let* ([ct (lookup-request-attribute "content-type" attrs)])
269    (let ([lst (string-split ct ";")])
270      (and (pair? lst) (car lst)) ) ) )
271
272(define (http:content-parser ct . p)
273  (if (pair? p)
274      (hash-table-set! content-parsers ct (car p))
275      (hash-table-ref/default content-parsers ct #f) ) )
276
277(define (find-content-parser type)
278  (or (http:content-parser type)
279      (lambda (size _ port) 
280        (let ((s (read-string size port)))
281          (values s s) ) ) ) )
282
283(define (lookup-request-attribute a attrs)
284  (and-let* ([a (assoc a attrs)]) (cdr a)) )
285
286(define (http:write-error-response code msg . port)
287  (let ((m ((http:error-response-handler) code msg))
288        (prot (protocol->string current-server-protocol)) )
289    (http:force-close #t)
290    (dribble "Error response: ~a ~a ~a" prot code msg)
291    (fprintf (:optional port (current-output-port))
292"~A ~A ~A\r
293Server: ~A\r
294Cache-Control: no-cache\r
295Content-Length: ~A\r
296Content-Type: text/html\r
297Connection: close\r
298\r
299~A"
300      prot code msg
301      current-server-name
302      (string-length m)
303      m) ) )
304
305(define http:error-response-handler
306  (make-parameter
307   (lambda (code msg)
308     (sprintf "<h1>~A ~A</h1>" code msg) ) ) )
309
310(define (http:write-bad-request-response . port)
311  (http:write-error-response 400 "Bad Request" (:optional port (current-output-port))) )
312
313(define (http:write-unsupported-protocol-response . port)
314  (http:write-error-response 505 "HTTP Version Not Supported" (:optional port (current-output-port))) )
315
316(define (http:write-not-found-response . port)
317  (http:write-error-response 404 "Not Found" (:optional port (current-output-port))) )
318
319(define (http:write-internal-error-response . port)
320  (http:write-error-response 500 "Internal Server Error" (:optional port (current-output-port))) )
321
322(define (output-connection-mode port req)
323  (if (eq? 'HTTP/1.0 (http:request-protocol req))
324      ;; Default for 1.0 is to close unless explicitly asked to keep alive
325      (sprintf "Connection: ~A\r\n"
326      (if (string-ci=? "keep-alive"
327                       (alist-ref "connection" (http:request-attributes req) string-ci=? ""))
328          "Keep-alive"
329          "Close"))
330          ;(fprintf port "Connection: Keep-alive\r\n")
331          ;(fprintf port "Connection: Close\r\n"))
332      ;; For 1.1 default is to keep alive unless explicitly asked to close
333      (if (string-ci=? "close"
334                       (alist-ref "connection" (http:request-attributes req) string-ci=? ""))
335           "Connection: Close\r\n")))
336          ;(fprintf port "Connection: Close\r\n"))))
337
338(define (http:write-response-header req #!optional [code 200] [msg "OK"] [alist '()] 
339                                    [port (current-output-port)]
340                                    [protocol current-server-protocol])
341  (let* ((prot (protocol->string protocol)) ; XXX What happens when request and response protocols don't match?
342         (result (sprintf "~A ~A ~A\r\nServer: ~A\r\n" prot code msg (default-property "Server" current-server-name alist))))
343    (dribble "Response: ~a ~a ~a" prot code msg)
344    ;(fprintf port "~A ~A ~A\r\nServer: ~A\r\n"
345;            prot
346;            code msg
347;            (default-property "Server" current-server-name alist) )
348    (set! result (sprintf "~A~A" result (output-connection-mode port req)))
349    (for-each
350     (lambda (h)
351       (let ([hd (car h)])
352         (unless (or (string-ci=? "Server" hd) (string-ci=? "Connection" hd))
353           (set! result (sprintf "~A~A: ~A\r\n" result hd (cdr h))))))
354           ;(fprintf port "~A: ~A\r\n" hd (cdr h)))))
355     alist)
356    (fprintf port "~A\r\n" result)))
357    ;(fprintf port "\r\n")))
358
359(define (default-property name def props)
360  (or (and-let* ([a (find (lambda (a) (string-ci=? name (car a))) props)])
361        (cdr a) )
362      def) )
363
364(define (handle-request req in out)
365  (let ([m (http:request-method req)])
366    (dribble "handling ~A request..." m)
367    (let ([h (http:request-method-handler m)])
368      (if h
369          (parameterize ([current-input-port in]
370                         [current-output-port out] )
371            (h req)
372            (flush-output out) )
373          (error "undefined request method handler" m (http:request-url req)) ) ) ) )
374
375(define request-method-handlers '())
376
377(define (http:request-method-handler m . h)
378  (let ([a (assq m request-method-handlers)])
379    (if (pair? h)
380        (if a 
381            (set-cdr! a (car h))
382            (set! request-method-handlers (alist-cons m (car h) request-method-handlers)) )
383        (and a (cdr a)) ) ) )
384
385(define (get/post-handler req)
386  (let-values (((loc get-args) (http:decode-url (http:request-url req))))
387    (let ([args (append
388                 (let ((body (http:request-body req)))
389                   (if (list? body)
390                       body
391                       '() ) )
392                 get-args)]
393          [h (http:find-resource loc)])
394      (if h
395          (handle-exceptions ex
396               (begin
397                 (dribble (with-output-to-string
398                            (lambda ()
399                              (print-error-message ex)
400                              (print-call-chain))))
401                 (http:write-internal-error-response))
402             (h req args))
403           ((http:fallback-handler) req) ) ))  )
404
405(define http:fallback-handler
406  (make-parameter
407   (lambda (r)
408     (http:write-not-found-response) ) ) )
409
410(http:request-method-handler 'GET get/post-handler)
411(http:request-method-handler 'POST get/post-handler)
412
413
414;;; Handling resources:
415
416(define resource-table (make-hash-table string=?))
417
418(define (http:add-resource url h)
419  (let ([urls (map ->string (if (pair? url) url (list url)))])
420    (for-each (cut hash-table-set! resource-table <> h) urls) ) )
421
422(define (http:remove-resource url)
423  (let ([urls (map ->string (if (pair? url) url (list url)))])
424    (for-each (cut hash-table-delete! resource-table <>) urls) ) )
425
426(define (http:find-resource url)
427  (hash-table-ref/default resource-table url #f) )
428
429
430;;; Builtin content parsers:
431
432;(http:content-parser 'text/xml (lambda (_ _ port) (ssax:xml->sxml port '())))
433
434(http:content-parser 
435 'application/x-www-form-urlencoded
436 (lambda (size _ port)
437   (let* ([raw (read-string size port)]
438          [data (string-split raw "&")])
439     (values
440      (map (lambda (def)
441             (regex-case def
442               ["([^=]+)=(.*)" (_ name value)
443                (cons name (http:canonicalize-string value)) ] 
444               [else (cons def #f)] ) )
445           data)
446      raw) ) ) )
Note: See TracBrowser for help on using the repository browser.