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

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

Minor reformatting to make code more compact

File size: 16.8 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 log-to
40   write-logged-response build-error-message
41   current-request remote-address local-address
42   current-response current-file current-pathinfo
43   server-software root-path server-port index-files mime-type-map
44   default-mime-type file-extension-handlers default-host vhost-map
45   access-log error-log debug-log spiffy-user spiffy-group
46   handle-directory handle-not-found handle-exception handle-access-logging
47   restart-request htmlize)
48
49(import chicken scheme extras ports files data-structures)
50(require-extension srfi-1 srfi-18 tcp regex posix
51                   intarweb uri-generic sendfile matchable)
52
53(define version 4)
54(define release 0)
55
56;;; Request processing information
57(define current-request  (make-parameter #f))
58(define current-response (make-parameter #f))
59(define current-file     (make-parameter #f))
60(define current-pathinfo (make-parameter #f))
61(define local-address    (make-parameter #f))
62(define remote-address   (make-parameter #f))
63
64;;; Configuration
65(define server-software  (make-parameter `(("Spiffy"
66                                            ,(conc version "." release)
67                                            ,(conc "Running on Chicken "
68                                                   (chicken-version))))))
69(define root-path        (make-parameter "./web"))
70(define server-port      (make-parameter 8080))
71(define index-files      (make-parameter '("index.html" "index.xhtml")))
72(define mime-type-map
73  (make-parameter
74   '(("xml" . text/xml)
75     ("html" . text/html)
76     ("xhtml" . text/xhtml+xml)
77     ("js"  . text/javascript)
78     ("pdf" . application/pdf)
79     ("css" . text/css)
80     ("png" . image/png)
81     ("ico" . image/x-icon)
82     ("gif" . image/gif)
83     ("jpeg" . image/jpeg)
84     ("jpg" . image/jpeg)
85     ("svg" . image/svg+xml)
86     ("bmp" . image/bmp)
87     ("txt" . text/plain))))
88(define default-mime-type (make-parameter 'application/octet-stream))
89(define file-extension-handlers (make-parameter '()))
90(define default-host (make-parameter "localhost")) ;; XXX Can we do without?
91(define vhost-map (make-parameter `((".*" . ,(lambda (continue) (continue))))))
92(define access-log (make-parameter #f))
93(define error-log (make-parameter (current-error-port)))
94(define debug-log (make-parameter #f))
95(define spiffy-user (make-parameter #f))
96(define spiffy-group (make-parameter #f))
97
98;;; Custom handlers
99(define handle-directory
100  (make-parameter
101   (lambda (path)
102     (send-status 403 "Forbidden"))))
103(define handle-file
104  (make-parameter
105   (lambda (path)
106     (let* ((ext (pathname-extension path))
107            (handler (alist-ref ext (file-extension-handlers)
108                                string-ci=? send-static-file)))
109       (handler path)))))
110(define handle-not-found
111  (make-parameter
112   (lambda (path)
113     (send-status 404 "Not found"
114                  "<p>The resource you requested could not be found</p>"))))
115(define handle-exception
116  (make-parameter
117   (lambda (exn chain)
118     (log-to (error-log) (build-error-message exn chain #t))
119     (send-status 500 "Internal server error"))))
120
121;; This is very powerful, but it also means people need to write quite
122;; a bit of code to change the line slightly. In this respect Apache-style
123;; log format strings could be better...
124(define handle-access-logging
125  (make-parameter
126   (lambda ()
127     (log-to (access-log)
128             "~A [~A] \"~A ~A HTTP/~A.~A\" ~A"
129             (remote-address)
130             (seconds->string (current-seconds))
131             (request-method (current-request))
132             (uri->string (request-uri (current-request)))
133             (request-major (current-request))
134             (request-minor (current-request))
135             (let ((product (header-contents 'user-agent
136                                             (request-headers (current-request)))))
137               (if product
138                   (product-unparser 'user-agent product)
139                   "**Unknown product**"))))))
140
141;;;; End of configuration parameters
142
143(define (with-output-to-log log thunk)
144  (when log
145    (if (output-port? log)
146        (with-output-to-port log thunk)
147        (with-output-to-file log thunk append:))))
148
149(define (log-to log fmt . rest)
150  (with-output-to-log log
151    (lambda ()
152      (apply printf fmt rest)
153      (newline))))
154
155(define build-error-message
156  (let* ((cpa condition-property-accessor)
157         (exn-message (cpa 'exn 'message "(no message)"))
158         (exn-location (cpa 'exn 'location "(unknown location)"))
159         (exn-arguments (cpa 'exn 'arguments '()))
160         (exn? (condition-predicate 'exn)))
161    (lambda (exn chain #!optional raw-output)
162      (with-output-to-string
163        (lambda ()
164          (if (exn? exn)
165              (begin
166                (unless raw-output (display "<h2>"))
167                (display "Error:")
168                (and-let* ((loc (exn-location exn)))
169                  (if raw-output
170                      (printf " (~A)" (->string loc))
171                      (printf " (<em>~A</em>)" (htmlize (->string loc)))))
172                (if raw-output
173                    (printf "\n~A\n" (exn-message exn))
174                    (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn))))
175                (unless (null? (exn-arguments exn))
176                        (unless raw-output (printf "<ul>"))
177                        (for-each
178                         (lambda (a)
179                           (##sys#with-print-length-limit
180                            120
181                            (lambda ()
182                              (if raw-output
183                                  (print (->string a))
184                                  (printf "<li>~A</li>"
185                                          (htmlize (->string a)))))))
186                         (exn-arguments exn))
187                        (unless raw-output
188                         (printf "</ul>")))
189                (if raw-output
190                    (print chain)
191                    (printf "<pre>~a</pre>" (htmlize chain))))
192              (begin
193                (##sys#with-print-length-limit
194                 120
195                 (lambda ()
196                   (if raw-output
197                       (printf "Uncaught exception:\n~S\n" exn)
198                       (printf "<h2>Uncaught exception:</h2>\n~S\n" exn)))))))))))
199
200(define (extension->mime-type ext)
201  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
202
203(define (write-logged-response)
204  ((handle-access-logging))
205  (write-response (current-response)))
206
207;; A simple utility procedure to render a status code with message
208(define (send-status code reason #!optional text)
209  (parameterize ((current-response
210                  (update-response (current-response)
211                                   code: code
212                                   reason: reason
213                                   headers:
214                                   (headers
215                                    `((content-type text/html))
216                                    (response-headers (current-response))))))
217    (write-logged-response)
218    (with-output-to-port (response-port (current-response))
219      (lambda ()
220        (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
221        (print "<!DOCTYPE html")
222        (print "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
223        (print "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
224        (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ")
225        (print "      xml:lang=\"en\" lang=\"en\">")
226        (print "  <head>")
227        (printf "    <title>~A - ~A</title>\n" code reason)
228        (print "  </head>")
229        (print "  <body>")
230        (printf "    <h1>~A - ~A</h1>\n" code reason)
231        (if text (display text))
232        (print "  </body>")
233        (print "</html>")))))
234
235(define (send-static-file filename)
236  (let ((path (make-pathname (root-path) filename)))
237    (with-headers `((content-length ,(file-size path))
238                    (content-type ,(extension->mime-type (pathname-extension filename))))
239      (lambda ()
240        (write-logged-response)
241        (let ((fd (file-open path (+ open/binary open/rdonly))))
242          (handle-exceptions exn (begin
243                                   (file-close fd)
244                                   (signal exn))
245                             (sendfile fd (response-port (current-response))))
246          (file-close fd))))))
247
248(define (with-headers new-headers thunk)
249  (parameterize ((current-response
250                  (update-response
251                   (current-response)
252                   headers: (headers new-headers
253                                     (response-headers (current-response))))))
254    (thunk)))
255
256(define (process-directory path)
257  (let ((index-page (find (lambda (ip)
258                            (file-exists?
259                             (make-pathname (list (root-path) path) ip)))
260                          (index-files))))
261    (if index-page
262        (process-entry (make-pathname path index-page) '())
263        ((handle-directory) (make-pathname "/" path)))))
264
265;; If an URL is missing a trailing slash, instead of directly serving
266;; its index-file, redirect to the URL _with_ trailing slash.  This
267;; prevents problems with relative references since the directory
268;; would be seen as the file component in the path and get replaced.
269(define (redirect-directory-root path)
270  (let* ((newloc (make-pathname path "/"))
271         (url (uri-relative-to (uri-reference newloc)
272                               (request-uri (current-request)))))
273    (with-headers `((location ,url))
274      (lambda () (send-status 301 "Moved permanently")))))
275
276(define (process-entry current-path remaining-path)
277  (let ((path (make-pathname (root-path) current-path)))
278    (cond
279     ;; TODO Check if there's a registered URI-handler first
280     ((directory? path)
281      (match remaining-path
282       (()    (redirect-directory-root (make-pathname "/" current-path)))
283       (("/") (process-directory current-path))
284       (else  (process-entry (make-pathname current-path (car remaining-path))
285                             (cdr remaining-path)))))
286     ((file-exists? path)
287      (parameterize ((current-pathinfo remaining-path)
288                     (current-file (make-pathname "/" current-path)))
289        ((handle-file) (current-file)))) ;; hmm, not too useful
290     (else ((handle-not-found) (list "/" current-path))))))
291
292;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
293;; If request URL is absolute, use that.  Otherwise, look at the Host header.
294;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of
295;; RFC 2616.  If no host line is present, it returns the default host
296;; for HTTP/1.0.
297(define (determine-vhost/port)
298  (let* ((request-uri (request-uri (current-request)))
299         (request-host (uri-host request-uri))
300         (host-header (header-value 'host (request-headers (current-request)))))
301    (if request-host
302        (values request-host (or (uri-port request-uri) 80))
303        (if host-header
304            (values (car host-header) (cdr host-header))
305            (if (and (= (request-major (current-request)) 1)
306                     (>= (request-minor (current-request)) 1))
307                (values #f #f)
308                (values (default-host) 80))))))
309
310(define (normalize-current-request-uri)
311  (receive (host port) (determine-vhost/port)
312    (if host
313        (update-request (current-request)
314                        uri: (uri-relative-to
315                              (request-uri (current-request))
316                              ;; XXX
317                              (absolute-uri (conc "http://" host ":" port))))
318        (current-request))))
319
320(define request-restarter (make-parameter #f)) ; Internal parameter
321
322(define (restart-request req)
323  ((request-restarter) req (request-restarter)))
324
325(define (handle-incoming-request in out)
326  (receive (local remote)
327    (tcp-addresses in)
328    (parameterize ((remote-address remote)
329                   (local-address local)
330                   (current-request (read-request in))
331                   (current-response
332                    (make-response port: out
333                                   headers: (headers
334                                             `((content-type text/html)
335                                               (server ,(server-software)))))))
336      (let ((path (uri-path (request-uri (current-request)))))
337        (receive (req cont)
338          (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
339          (parameterize ((current-request req)
340                         (request-restarter cont))
341            (handle-exceptions
342             exn ((handle-exception) exn
343                  (with-output-to-string print-call-chain))
344             (if (and (uri-host (request-uri (current-request))) (pair? path))
345                 (let* ((host (uri-host (request-uri (current-request))))
346                        (handler (alist-ref host (vhost-map)
347                                            (lambda (h _)
348                                              (if (not (regexp? h))
349                                                  (string-match (regexp h #t) host)
350                                                  (string-match h host))))))
351                   (if handler
352                       (handler (lambda () (process-entry "" path)))
353                       ;; Is this ok?
354                       (send-status 404 "Not found" "<p>Host not found</p>")))
355                 ;; No host in the request? That's an error.
356                 (send-status 400 "Bad request"
357                              "<p>Your client sent a request that the server did not understand</p>")))))
358        ;; For now, just close the ports and allow the thread to exit
359        (close-output-port out)
360        (close-input-port in)))))
361
362(define (htmlize str)
363  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
364                           ("\"" . "&quot;") ("&" . "&amp;"))))
365
366;; Do we want this here?
367(unless (eq? (build-platform) 'msvc)
368  (set-signal-handler! signal/int (lambda (sig) (exit 1))))
369
370(define (switch-user/group user group)
371  (when group    ; group first, since only superuser can switch groups
372    (let ((ginfo (group-information group)))
373      (unless ginfo
374        (error "Group does not exist" group))
375      (set! (current-group-id) (list-ref ginfo 2))))
376  (when user
377    (let ((uinfo (user-information user)))
378      (unless uinfo
379        (error "User does not exist" user))
380      (setenv "HOME" (list-ref uinfo 5))
381      (initialize-groups user (list-ref uinfo 3))
382      (unless group ; Already changed to target group?
383        (set! (current-group-id) (list-ref uinfo 3)))
384      (set! (current-user-id) (list-ref uinfo 2)))))
385
386(define (start-server #!key (port (server-port)))
387  (parameterize ((load-verbose #f))
388    (letrec ((listener (tcp-listen port))
389             (init (lambda ()
390                     (switch-user/group (spiffy-user) (spiffy-group))))
391             (accept-loop (lambda ()
392                            (receive (in out)
393                              (tcp-accept listener)
394                              (thread-start!
395                               (make-thread (lambda ()
396                                              (handle-incoming-request in out))))
397                              (accept-loop)))))
398      (init)
399      (accept-loop))))
400
401)
Note: See TracBrowser for help on using the repository browser.