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

Last change on this file since 15509 was 15509, checked in by sjamaan, 10 years ago

Implement bind-address

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