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

Last change on this file since 13206 was 13206, checked in by sjamaan, 11 years ago

Update spiffy redirect handling so it generates an absolute URI (but does not change the request uri itself) and add a test for this. Refactor testlib a bit

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