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

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

Add checks for traversal attacks

File size: 18.0 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 (or (uri-port request-uri) 80))
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) 80))))))
333
334(define (normalize-current-request-uri)
335  (receive (host port)
336    (determine-vhost/port)
337    (let* ((uri (request-uri (current-request)))
338           (host (or host (uri-host uri)))
339           (port (or port (uri-port uri))))
340     (update-request (current-request)
341                     uri: (update-uri uri host: host port: port)))))
342
343(define request-restarter (make-parameter #f)) ; Internal parameter
344
345(define (restart-request req)
346  ((request-restarter) req (request-restarter)))
347
348(define (handle-incoming-request in out)
349  (receive (local remote)
350    (tcp-addresses in)
351    (handle-exceptions ; XXX FIXME; this should be more fine-grained
352     exn (fprintf out "Invalid request")
353     (parameterize ((remote-address remote)
354                    (local-address local)
355                    (current-request (read-request in))
356                    (current-response
357                     (make-response port: out
358                                    headers: (headers
359                                              `((content-type text/html)
360                                                (server ,(server-software)))))))
361       (receive (req cont)
362         (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
363         (parameterize ((current-request req)
364                        (request-restarter cont))
365           (handle-exceptions
366            exn ((handle-exception) exn
367                 (with-output-to-string print-call-chain))
368            (let ((path (uri-path (request-uri (current-request)))))
369              (if (and (uri-host (request-uri (current-request))) (pair? path)
370                       (eq? (car path) '/))
371                  (let* ((host (uri-host (request-uri (current-request))))
372                         (handler (alist-ref host (vhost-map)
373                                             (lambda (h _)
374                                               (if (not (regexp? h))
375                                                   (string-match (regexp h #t) host)
376                                                   (string-match h host))))))
377                    (if handler
378                        (handler (lambda () (process-entry "" "" (cdr path))))
379                        ;; Is this ok?
380                        ((handle-not-found) path)))
381                  ;; No host in the request? That's an error.
382                  (send-status 400 "Bad request"
383                               "<p>Your client sent a request that the server did not understand</p>"))))))
384       ;; For now, just close the ports and allow the thread to exit
385       (close-output-port out)
386       (close-input-port in)))))
387
388(define (htmlize str)
389  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
390                           ("\"" . "&quot;") ("'" . "&apos;") ("&" . "&amp;"))))
391
392;; Do we want this here?
393(unless (eq? (build-platform) 'msvc)
394  (set-signal-handler! signal/int (lambda (sig) (exit 1))))
395
396(define (switch-user/group user group)
397  (when group    ; group first, since only superuser can switch groups
398    (let ((ginfo (group-information group)))
399      (unless ginfo
400        (error "Group does not exist" group))
401      (set! (current-group-id) (list-ref ginfo 2))))
402  (when user
403    (let ((uinfo (user-information user)))
404      (unless uinfo
405        (error "User does not exist" user))
406      (setenv "HOME" (list-ref uinfo 5))
407      (initialize-groups user (list-ref uinfo 3))
408      (unless group ; Already changed to target group?
409        (set! (current-group-id) (list-ref uinfo 3)))
410      (set! (current-user-id) (list-ref uinfo 2)))))
411
412(define (start-server #!key (port (server-port)))
413  (parameterize ((load-verbose #f))
414    (letrec ((listener (tcp-listen port))
415             (init (lambda ()
416                     (switch-user/group (spiffy-user) (spiffy-group))))
417             (accept-loop (lambda ()
418                            (receive (in out)
419                              (tcp-accept listener)
420                              (thread-start!
421                               (make-thread (lambda ()
422                                              (handle-incoming-request in out))))
423                              (accept-loop)))))
424      (init)
425      (accept-loop))))
426
427)
Note: See TracBrowser for help on using the repository browser.