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

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

Tag Spiffy 4.5

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