source: project/release/4/spiffy/trunk/spiffy.scm @ 12478

Last change on this file since 12478 was 12478, checked in by sjamaan, 12 years ago

Add local and remote IP-addresses to params. Implement more of CGI spec. Up until section 4, most is implemented now

File size: 13.6 KB
Line 
1;;
2;; Spiffy the web server
3;;
4; Copyright (c) 2007-2008, Peter Bex
5; Copyright (c) 2000-2005, Felix L. Winkelmann
6; All rights reserved.
7;
8; Redistribution and use in source and binary forms, with or without
9; modification, are permitted provided that the following conditions
10; are met:
11;
12; 1. Redistributions of source code must retain the above copyright
13;    notice, this list of conditions and the following disclaimer.
14; 2. Redistributions in binary form must reproduce the above copyright
15;    notice, this list of conditions and the following disclaimer in the
16;    documentation and/or other materials provided with the distribution.
17; 3. Neither the name of the author nor the names of its
18;    contributors may be used to endorse or promote products derived
19;    from this software without specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
26; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
27; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
28; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
30; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
32; OF THE POSSIBILITY OF SUCH DAMAGE.
33;
34; Please report bugs, suggestions and ideas to the Chicken Trac
35; ticket tracking system (assign tickets to user 'sjamaan'):
36; http://trac.callcc.org
37
38(module spiffy
39  (start-server with-headers send-status send-static-file
40   current-request remote-address local-address
41   current-response current-file current-pathinfo
42   server-software root-path server-port index-files mime-type-map
43   default-mime-type file-extension-handlers default-host vhost-map
44   handle-directory handle-not-found handle-exception
45   restart-request htmlize)
46
47(import chicken scheme extras ports files data-structures)
48(require-extension srfi-1 srfi-18 posix tcp regex
49                   intarweb uri-generic sendfile matchable)
50
51(define version 4)
52(define release 0)
53
54;;; Request processing information
55(define current-request  (make-parameter #f))
56(define current-response (make-parameter #f))
57(define current-file     (make-parameter #f))
58(define current-pathinfo (make-parameter #f))
59(define local-address    (make-parameter #f))
60(define remote-address   (make-parameter #f))
61
62;;; Configuration
63(define server-software  (make-parameter (conc "Spiffy/" version "." release)))
64(define root-path        (make-parameter "./web"))
65(define server-port      (make-parameter 8080))
66(define index-files      (make-parameter '("index.html" "index.xhtml")))
67(define mime-type-map
68  (make-parameter
69   '(("xml" . text/xml)
70     ("html" . text/html)
71     ("xhtml" . text/xhtml+xml)
72     ("js"  . text/javascript)
73     ("pdf" . application/pdf)
74     ("css" . text/css)
75     ("png" . image/png)
76     ("ico" . image/x-icon)
77     ("gif" . image/gif)
78     ("jpeg" . image/jpeg)
79     ("jpg" . image/jpeg)
80     ("svg" . image/svg+xml)
81     ("bmp" . image/bmp)
82     ("txt" . text/plain))))
83(define default-mime-type (make-parameter 'application/octet-stream))
84(define file-extension-handlers (make-parameter '()))
85(define default-host (make-parameter "localhost")) ;; XXX Can we do without?
86(define vhost-map (make-parameter `((".*" . ,(lambda (continue) (continue))))))
87
88;;; Custom handlers
89(define handle-directory
90  (make-parameter
91   (lambda (path)
92     (send-status 403 "Forbidden"))))
93(define handle-file
94  (make-parameter
95   (lambda (path)
96     (let* ((ext (pathname-extension path))
97            (handler (alist-ref ext (file-extension-handlers)
98                                string-ci=? send-static-file)))
99       (handler path)))))
100(define handle-not-found
101  (make-parameter
102   (lambda (path)
103     (send-status 404 "Not found"
104                  "<p>The resource you requested could not be found</p>"))))
105(define handle-exception
106  (make-parameter
107   (lambda (exn chain)
108     (send-status 500 "Internal server error" (build-error-message exn chain)))))
109
110(define build-error-message
111  (let* ((cpa condition-property-accessor)
112         (exn-message (cpa 'exn 'message "(no message)"))
113         (exn-location (cpa 'exn 'location "(unknown location)"))
114         (exn-arguments (cpa 'exn 'arguments '()))
115         (exn? (condition-predicate 'exn)))
116    (lambda (exn chain)
117      (with-output-to-string
118        (lambda ()
119          (if (exn? exn)
120              (begin
121                (display "<h2>Error:")
122                (and-let* ((loc (exn-location exn)))
123                  (printf " (<em>~A</em>)" (htmlize (->string loc))))
124                (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn)))
125                (unless (null? (exn-arguments exn))
126                        (printf "<ul>")
127                        (for-each
128                         (lambda (a)
129                           (##sys#with-print-length-limit 120 (lambda () (printf "<li>~S</li>" (htmlize (->string a))))))
130                         (exn-arguments exn))
131                        (printf "</ul>"))
132                (printf "<pre>~a</pre>" (htmlize chain)))
133              (begin
134                (##sys#with-print-length-limit
135                 120
136                 (lambda ()
137                   (printf "<h2>Uncaught exception:</h2>\n~S" exn))))))))))
138
139;;; Internal parameters
140(define request-restarter (make-parameter #f))
141
142(define (extension->mime-type ext)
143  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
144
145;; A simple utility procedure to render a status code with message
146(define (send-status code reason #!optional text)
147  (parameterize ((current-response
148                  (update-response (current-response)
149                                   code: code
150                                   reason: reason
151                                   headers:
152                                   (headers
153                                    `((content-type text/html))
154                                    (response-headers (current-response))))))
155    (write-response (current-response))
156    (with-output-to-port (response-port (current-response))
157      (lambda ()
158        (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
159        (print "<!DOCTYPE html")
160        (print "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
161        (print "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
162        (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ")
163        (print "      xml:lang=\"en\" lang=\"en\">")
164        (print "  <head>")
165        (printf "    <title>~A - ~A</title>\n" code reason)
166        (print "  </head>")
167        (print "  <body>")
168        (printf "    <h1>~A - ~A</h1>\n" code reason)
169        (if text (display text))
170        (print "  </body>")
171        (print "</html>")))))
172
173(define (send-static-file filename)
174  (let ((path (make-pathname (root-path) filename)))
175    (with-headers `((content-length ,(file-size path))
176                    (content-type ,(extension->mime-type (pathname-extension filename))))
177      (lambda ()
178        (write-response (current-response))
179        (let ((fd (file-open path (+ open/binary open/rdonly))))
180          (handle-exceptions exn (begin
181                                   (file-close fd)
182                                   (signal exn))
183                             (sendfile fd (response-port (current-response))))
184          (file-close fd))))))
185
186(define (with-headers new-headers thunk)
187  (parameterize ((current-response
188                  (update-response
189                   (current-response)
190                   headers: (headers new-headers
191                                     (response-headers (current-response))))))
192    (thunk)))
193
194(define (process-directory path)
195  (let ((index-page (find (lambda (ip)
196                            (file-exists?
197                             (make-pathname (list (root-path) path) ip)))
198                          (index-files))))
199    (if index-page
200        (process-entry (make-pathname path index-page) '())
201        ((handle-directory) (make-pathname "/" path)))))
202
203;; If an URL is missing a trailing slash, instead of directly serving
204;; its index-file, redirect to the URL _with_ trailing slash.  This
205;; prevents problems with relative references since the directory
206;; would be seen as the file component in the path and get replaced.
207(define (redirect-directory-root path)
208  (let* ((newloc (make-pathname path "/"))
209         (url (uri-relative-to (uri-reference newloc)
210                               (request-uri (current-request)))))
211    (with-headers `((location ,url))
212      (lambda () (send-status 301 "Moved permanently")))))
213
214(define (process-entry current-path remaining-path)
215  (let ((path (make-pathname (root-path) current-path)))
216    (cond
217     ;; TODO Check if there's a registered URI-handler first
218     ((directory? path)
219      (match remaining-path
220       (()    (redirect-directory-root (make-pathname "/" current-path)))
221       (("/") (process-directory current-path))
222       (else  (process-entry (make-pathname current-path (car remaining-path))
223                             (cdr remaining-path)))))
224     ((file-exists? path)
225      (parameterize ((current-pathinfo remaining-path)
226                     (current-file (make-pathname "/" current-path)))
227        ((handle-file) (current-file)))) ;; hmm, not too useful
228     (else ((handle-not-found) (list "/" current-path))))))
229
230;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
231;; If request URL is absolute, use that.  Otherwise, look at the Host header.
232;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of
233;; RFC 2616.  If no host line is present, it returns the default host
234;; for HTTP/1.0.
235(define (determine-vhost/port)
236  (let* ((request-uri (request-uri (current-request)))
237         (request-host (uri-host request-uri))
238         (host-header (header-value 'host (request-headers (current-request)))))
239    (if request-host
240        (values request-host (or (uri-port request-uri) 80))
241        (if host-header
242            (values (car host-header) (cdr host-header))
243            (if (and (= (request-major (current-request)) 1)
244                     (>= (request-minor (current-request)) 1))
245                (values #f #f)
246                (values (default-host) 80))))))
247
248(define (normalize-current-request-uri)
249  (receive (host port) (determine-vhost/port)
250    (if host
251        (update-request (current-request)
252                        uri: (uri-relative-to
253                              (request-uri (current-request))
254                              ;; XXX
255                              (absolute-uri (conc "http://" host ":" port))))
256        (current-request))))
257
258(define (restart-request req)
259  ((request-restarter) req (request-restarter)))
260
261(define (handle-incoming-request in out)
262  (receive (local remote)
263    (tcp-addresses in)
264    (parameterize ((remote-address remote)
265                   (local-address local)
266                   (current-request (read-request in))
267                   (current-response
268                    (make-response port: out
269                                   headers: (headers
270                                             `((content-type text/html))))))
271      (let ((path (uri-path (request-uri (current-request)))))
272        (receive (req cont)
273          (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
274          (parameterize ((current-request req)
275                         (request-restarter cont))
276            (handle-exceptions exn ((handle-exception) exn
277                                    (with-output-to-string print-call-chain))
278                               (if (and (uri-host (request-uri (current-request))) (pair? path))
279                                   (let* ((host (uri-host (request-uri (current-request))))
280                                          (handler (alist-ref host
281                                                              (vhost-map)
282                                                              (lambda (h _)
283                                                                (if (not (regexp? h))
284                                                                    (string-match (regexp h #t) host)
285                                                                    (string-match h host))))))
286                                     (if handler
287                                         (handler (lambda () (process-entry "" path)))
288                                         ;; Is this ok?
289                                         (send-status 404 "Not found" "<p>Host not found</p>")))
290                                   ;; No host in the request? That's an error.
291                                   (send-status 400 "Bad request"
292                                                "<p>Your client sent a request that the server did not understand</p>")))))
293        ;; For now, just close the ports and allow the thread to exit
294        (close-output-port out)
295        (close-input-port in)))))
296
297(define (htmlize str)
298  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
299                           ("\"" . "&quot;") ("&" . "&amp;"))))
300
301(define (start-server #!key (port (server-port)))
302  (parameterize ((load-verbose #f))
303   (letrec ((listener (tcp-listen port))
304            (accept-loop (lambda ()
305                           (receive (in out)
306                             (tcp-accept listener)
307                             (thread-start!
308                              (make-thread (lambda ()
309                                             (handle-incoming-request in out))))
310                             (accept-loop)))))
311     (accept-loop))))
312
313)
Note: See TracBrowser for help on using the repository browser.