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

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

Add response code and referer to default access log, so it's more like apache and lighttpd's default

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