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

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

Fix URI normalization (probably needs some tweaking, but for now it's ok)

File size: 18.1 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 index-files mime-type-map
46   default-mime-type file-extension-handlers default-host vhost-map
47   access-log error-log debug-log spiffy-user spiffy-group access-file
48   handle-file handle-directory handle-not-found handle-exception
49   handle-access-logging restart-request htmlize)
50
51(import chicken scheme extras ports files data-structures)
52(require-extension srfi-1 srfi-13 srfi-18 tcp regex posix
53                   intarweb uri-common sendfile matchable)
54
55(define version 4)
56(define release 0)
57
58;;; Request processing information
59(define current-request  (make-parameter #f))
60(define current-response (make-parameter #f))
61(define current-file     (make-parameter #f))
62(define current-pathinfo (make-parameter #f))
63(define local-address    (make-parameter #f))
64(define remote-address   (make-parameter #f))
65
66;;; Configuration
67(define server-software  (make-parameter `(("Spiffy"
68                                            ,(conc version "." release)
69                                            ,(conc "Running on Chicken "
70                                                   (chicken-version))))))
71(define root-path        (make-parameter "./web"))
72(define server-port      (make-parameter 8080))
73(define index-files      (make-parameter '("index.html" "index.xhtml")))
74(define mime-type-map
75  (make-parameter
76   '(("xml" . text/xml)
77     ("html" . text/html)
78     ("xhtml" . text/xhtml+xml)
79     ("js"  . text/javascript)
80     ("pdf" . application/pdf)
81     ("css" . text/css)
82     ("png" . image/png)
83     ("ico" . image/x-icon)
84     ("gif" . image/gif)
85     ("jpeg" . image/jpeg)
86     ("jpg" . image/jpeg)
87     ("svg" . image/svg+xml)
88     ("bmp" . image/bmp)
89     ("txt" . text/plain))))
90(define default-mime-type (make-parameter 'application/octet-stream))
91(define file-extension-handlers (make-parameter '()))
92(define default-host (make-parameter "localhost")) ;; XXX Can we do without?
93(define vhost-map (make-parameter `((".*" . ,(lambda (continue) (continue))))))
94(define access-log (make-parameter #f))
95(define error-log (make-parameter (current-error-port)))
96(define debug-log (make-parameter #f))
97(define spiffy-user (make-parameter #f))
98(define spiffy-group (make-parameter #f))
99(define access-file (make-parameter #f))
100
101;;; Custom handlers
102(define handle-directory
103  (make-parameter
104   (lambda (path)
105     (send-status 403 "Forbidden"))))
106(define handle-file
107  (make-parameter
108   (lambda (path)
109     (let* ((ext (pathname-extension path))
110            (handler (alist-ref ext (file-extension-handlers)
111                                string-ci=? send-static-file)))
112       (handler path)))))
113(define handle-not-found
114  (make-parameter
115   (lambda (path)
116     (send-status 404 "Not found"
117                  "<p>The resource you requested could not be found</p>"))))
118(define handle-exception
119  (make-parameter
120   (lambda (exn chain)
121     (log-to (error-log) (build-error-message exn chain #t))
122     (send-status 500 "Internal server error"))))
123
124;; This is very powerful, but it also means people need to write quite
125;; a bit of code to change the line slightly. In this respect Apache-style
126;; log format strings could be better...
127(define handle-access-logging
128  (make-parameter
129   (lambda ()
130     (log-to (access-log)
131             "~A [~A] \"~A ~A HTTP/~A.~A\" ~A"
132             (remote-address)
133             (seconds->string (current-seconds))
134             (request-method (current-request))
135             (uri->string (request-uri (current-request)))
136             (request-major (current-request))
137             (request-minor (current-request))
138             (let ((product (header-contents 'user-agent
139                                             (request-headers (current-request)))))
140               (if product
141                   (product-unparser 'user-agent product)
142                   "**Unknown product**"))))))
143
144;;;; End of configuration parameters
145
146(define (with-output-to-log log thunk)
147  (when log
148    (if (output-port? log)
149        (with-output-to-port log thunk)
150        (with-output-to-file log thunk append:))))
151
152(define (log-to log fmt . rest)
153  (with-output-to-log log
154    (lambda ()
155      (apply printf fmt rest)
156      (newline))))
157
158(define build-error-message
159  (let* ((cpa condition-property-accessor)
160         (exn-message (cpa 'exn 'message "(no message)"))
161         (exn-location (cpa 'exn 'location "(unknown location)"))
162         (exn-arguments (cpa 'exn 'arguments '()))
163         (exn? (condition-predicate 'exn)))
164    (lambda (exn chain #!optional raw-output)
165      (with-output-to-string
166        (lambda ()
167          (if (exn? exn)
168              (begin
169                (unless raw-output (display "<h2>"))
170                (display "Error:")
171                (and-let* ((loc (exn-location exn)))
172                  (if raw-output
173                      (printf " (~A)" (->string loc))
174                      (printf " (<em>~A</em>)" (htmlize (->string loc)))))
175                (if raw-output
176                    (printf "\n~A\n" (exn-message exn))
177                    (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn))))
178                (unless (null? (exn-arguments exn))
179                        (unless raw-output (printf "<ul>"))
180                        (for-each
181                         (lambda (a)
182                           (##sys#with-print-length-limit
183                            120
184                            (lambda ()
185                              (if raw-output
186                                  (print (->string a))
187                                  (printf "<li>~A</li>"
188                                          (htmlize (->string a)))))))
189                         (exn-arguments exn))
190                        (unless raw-output
191                         (printf "</ul>")))
192                (if raw-output
193                    (print chain)
194                    (printf "<pre>~a</pre>" (htmlize chain))))
195              (begin
196                (##sys#with-print-length-limit
197                 120
198                 (lambda ()
199                   (if raw-output
200                       (printf "Uncaught exception:\n~S\n" exn)
201                       (printf "<h2>Uncaught exception:</h2>\n~S\n" exn)))))))))))
202
203(define (extension->mime-type ext)
204  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
205
206(define (write-logged-response)
207  ((handle-access-logging))
208  (write-response (current-response)))
209
210;; A simple utility procedure to render a status code with message
211(define (send-status code reason #!optional text)
212  (parameterize ((current-response
213                  (update-response (current-response)
214                                   code: code
215                                   reason: reason
216                                   headers:
217                                   (headers
218                                    `((content-type text/html))
219                                    (response-headers (current-response))))))
220    (write-logged-response)
221    (with-output-to-port (response-port (current-response))
222      (lambda ()
223        (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
224        (print "<!DOCTYPE html")
225        (print "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
226        (print "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
227        (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ")
228        (print "      xml:lang=\"en\" lang=\"en\">")
229        (print "  <head>")
230        (printf "    <title>~A - ~A</title>\n" code reason)
231        (print "  </head>")
232        (print "  <body>")
233        (printf "    <h1>~A - ~A</h1>\n" code reason)
234        (if text (display text))
235        (print "  </body>")
236        (print "</html>")))))
237
238(define (send-static-file filename)
239  (let ((path (make-pathname (root-path) filename)))
240    (with-headers `((content-length ,(file-size path))
241                    (content-type ,(extension->mime-type
242                                    (pathname-extension filename))))
243      (lambda ()
244        (write-logged-response)
245        (let ((fd (file-open path (+ open/binary open/rdonly))))
246          (handle-exceptions exn (begin
247                                   (file-close fd)
248                                   (signal exn))
249                             (sendfile fd (response-port (current-response))))
250          (file-close fd))))))
251
252(define (with-headers new-headers thunk)
253  (parameterize ((current-response
254                  (update-response
255                   (current-response)
256                   headers: (headers new-headers
257                                     (response-headers (current-response))))))
258    (thunk)))
259
260(define (process-directory path)
261  (let ((index-page (find (lambda (ip)
262                            (file-exists?
263                             (make-pathname (list (root-path) path) ip)))
264                          (index-files))))
265    (if index-page
266        (process-entry path index-page '())
267        ((handle-directory) (make-pathname "/" path)))))
268
269;; If an URL is missing a trailing slash, instead of directly serving
270;; its index-file, redirect to the URL _with_ trailing slash.  This
271;; prevents problems with relative references since the directory
272;; would be seen as the file component in the path and get replaced.
273(define (redirect-directory-root path)
274  (let ((new-path (uri-path (uri-reference (string-append path "/")))))
275   (with-headers `((location ,(update-uri (request-uri (current-request))
276                                          path: new-path)))
277     (lambda () (send-status 301 "Moved permanently")))))
278
279(define (apply-access-file path continue)
280  (let ((file (make-pathname path (access-file))))
281    (if (and (access-file) (file-exists? file))
282        ((eval (call-with-input-file file read)) continue)
283        (continue))))
284
285;; Is the file impossible to be requested directly?
286;;
287;; Any file that the the filesystem is incapable of representing is
288;; considered impossible to request.  This includes files with a name that
289;; includes a slash, and "." and ".." because they are special files.
290;; If this is requested, it's probably an encoded traversal attack
291(define (impossible-filename? name)
292  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
293
294(define (process-entry previous-path fragment remaining-path)
295  (let* ((current-path (make-pathname previous-path fragment))
296         (full-path (make-pathname (root-path) current-path)))
297    (cond
298     ;; TODO Check if there's a registered URI-handler first
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/port)
322  (let* ((request-uri (request-uri (current-request)))
323         (request-host (uri-host request-uri))
324         (host-header (header-value 'host (request-headers (current-request)))))
325    (if request-host
326        (values request-host (server-port))
327        (if host-header
328            (values (car host-header) (cdr host-header))
329            (if (and (= (request-major (current-request)) 1)
330                     (>= (request-minor (current-request)) 1))
331                (values #f #f)
332                (values (default-host) (server-port)))))))
333
334(define (normalize-current-request-uri)
335  (receive (vhost vport)
336    (determine-vhost/port)
337    (let* ((uri (request-uri (current-request)))
338           (host (or vhost (uri-host uri)))
339           (port (or vport (uri-port uri) (server-port)))
340           (scheme (or (uri-scheme uri) 'http))) ; XXX
341      (update-request (current-request)
342                      uri: (update-uri uri scheme: scheme host: host port: port)))))
343
344(define request-restarter (make-parameter #f)) ; Internal parameter
345
346(define (restart-request req)
347  ((request-restarter) req (request-restarter)))
348
349(define (handle-incoming-request in out)
350  (receive (local remote)
351    (tcp-addresses in)
352    (handle-exceptions ; XXX FIXME; this should be more fine-grained
353     exn (fprintf out "Invalid request")
354     (parameterize ((remote-address remote)
355                    (local-address local)
356                    (current-request (read-request in))
357                    (current-response
358                     (make-response port: out
359                                    headers: (headers
360                                              `((content-type text/html)
361                                                (server ,(server-software)))))))
362       (receive (req cont)
363         (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
364         (parameterize ((current-request req)
365                        (request-restarter cont))
366           (handle-exceptions
367            exn ((handle-exception) exn
368                 (with-output-to-string print-call-chain))
369            (let ((path (uri-path (request-uri (current-request)))))
370              (if (and (uri-host (request-uri (current-request))) (pair? path)
371                       (eq? (car path) '/))
372                  (let* ((host (uri-host (request-uri (current-request))))
373                         (handler (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 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;") ("'" . "&apos;") ("&" . "&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.