;; ;; Spiffy the web server ;; ; Copyright (c) 2007-2009, Peter Bex ; Copyright (c) 2000-2005, Felix L. Winkelmann ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; 3. Neither the name of the author nor the names of its ; contributors may be used to endorse or promote products derived ; from this software without specific prior written permission. ; ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ; OF THE POSSIBILITY OF SUCH DAMAGE. ; ; Please report bugs, suggestions and ideas to the Chicken Trac ; ticket tracking system (assign tickets to user 'sjamaan'): ; http://trac.callcc.org (provide 'spiffy) (module spiffy (start-server with-headers send-status send-static-file log-to write-logged-response build-error-message current-request remote-address local-address current-response current-file current-pathinfo server-software root-path server-port server-ssl-context server-bind-address server-root-uri index-files mime-type-map default-mime-type file-extension-handlers default-host vhost-map access-log error-log debug-log spiffy-user spiffy-group access-file max-connections handle-file handle-directory handle-not-found handle-exception handle-access-logging restart-request htmlize) (import chicken scheme extras ports files data-structures) (require-extension srfi-1 srfi-13 srfi-18 tcp regex posix openssl intarweb uri-common sendfile matchable) (define version 4) (define release 1) ;;; Request processing information (define current-request (make-parameter #f)) (define current-response (make-parameter #f)) (define current-file (make-parameter #f)) (define current-pathinfo (make-parameter #f)) (define local-address (make-parameter #f)) (define remote-address (make-parameter #f)) ;;; Configuration (define server-software (make-parameter `(("Spiffy" ,(conc version "." release) ,(conc "Running on Chicken " (chicken-version)))))) (define root-path (make-parameter "./web")) (define server-port (make-parameter 8080)) (define server-ssl-context (make-parameter #f)) (define server-bind-address (make-parameter #f)) (define index-files (make-parameter '("index.html" "index.xhtml"))) (define mime-type-map (make-parameter '(("xml" . text/xml) ("html" . text/html) ("xhtml" . text/xhtml+xml) ("js" . text/javascript) ("pdf" . application/pdf) ("css" . text/css) ("png" . image/png) ("ico" . image/x-icon) ("gif" . image/gif) ("jpeg" . image/jpeg) ("jpg" . image/jpeg) ("svg" . image/svg+xml) ("bmp" . image/bmp) ("txt" . text/plain)))) (define default-mime-type (make-parameter 'application/octet-stream)) (define file-extension-handlers (make-parameter '())) (define default-host (make-parameter "localhost")) ;; XXX Can we do without? (define vhost-map (make-parameter `((".*" . ,(lambda (cont) (cont)))))) (define access-log (make-parameter #f)) (define error-log (make-parameter (current-error-port))) (define debug-log (make-parameter #f)) (define spiffy-user (make-parameter #f)) (define spiffy-group (make-parameter #f)) (define access-file (make-parameter #f)) (define max-connections (make-parameter 1024)) ;;; Custom handlers (define handle-directory (make-parameter (lambda (path) (send-status 403 "Forbidden")))) (define handle-file (make-parameter (lambda (path) (let* ((ext (pathname-extension path)) (handler (alist-ref ext (file-extension-handlers) string-ci=? send-static-file))) (handler path))))) (define handle-not-found (make-parameter (lambda (path) (send-status 404 "Not found" "
The resource you requested could not be found
")))) (define handle-exception (make-parameter (lambda (exn chain) (log-to (error-log) "~A" (build-error-message exn chain #t)) (send-status 500 "Internal server error")))) ;; This is very powerful, but it also means people need to write quite ;; a bit of code to change the line slightly. In this respect Apache-style ;; log format strings could be better... (define handle-access-logging (make-parameter (lambda () (let ((h (request-headers (current-request)))) (log-to (access-log) "~A [~A] \"~A ~A HTTP/~A.~A\" ~A \"~A\" \"~A\"" (remote-address) (seconds->string (current-seconds)) (request-method (current-request)) (uri->string (request-uri (current-request))) (request-major (current-request)) (request-minor (current-request)) (response-code (current-response)) (uri->string (header-value 'referer h (uri-reference "-"))) (let ((product (header-contents 'user-agent h))) (if product (product-unparser 'user-agent product) "**Unknown product**"))))))) ;;;; End of configuration parameters (define (with-output-to-log log thunk) (when log (if (output-port? log) (with-output-to-port log thunk) (with-output-to-file log thunk append:)))) (define (log-to log fmt . rest) (with-output-to-log log (lambda () (apply printf fmt rest) (newline)))) (define build-error-message (let* ((cpa condition-property-accessor) (exn-message (cpa 'exn 'message "(no message)")) (exn-location (cpa 'exn 'location "(unknown location)")) (exn-arguments (cpa 'exn 'arguments '())) (exn? (condition-predicate 'exn))) (lambda (exn chain #!optional raw-output) (with-output-to-string (lambda () (if (exn? exn) (begin (unless raw-output (display "~a" (htmlize chain)))) (begin (##sys#with-print-length-limit 120 (lambda () (if raw-output (printf "Uncaught exception:\n~S\n" exn) (printf "
Your client sent a request that the server did not understand
")) (handle-another-request?))))))) ; Keep going? (define (htmlize str) (string-translate* str '(("<" . "<") (">" . ">") ("\"" . """) ("'" . "'") ("&" . "&")))) ;; Do we want this here? (unless (eq? (build-platform) 'msvc) (set-signal-handler! signal/int (lambda (sig) (exit 1)))) (define (switch-user/group user group) (when group ; group first, since only superuser can switch groups (let ((ginfo (group-information group))) (unless ginfo (error "Group does not exist" group)) (set! (current-group-id) (list-ref ginfo 2)))) (when user (let ((uinfo (user-information user))) (unless uinfo (error "User does not exist" user)) (setenv "HOME" (list-ref uinfo 5)) (initialize-groups user (list-ref uinfo 3)) (unless group ; Already changed to target group? (set! (current-group-id) (list-ref uinfo 3))) (set! (current-user-id) (list-ref uinfo 2))))) (define (mutex-update! m op) (dynamic-wind (lambda () (mutex-lock! m)) (lambda () (mutex-specific-set! m (op (mutex-specific m)))) (lambda () (mutex-unlock! m)))) (define (make-mutex/value name value) (let ((m (make-mutex name))) (mutex-specific-set! m value) m)) (define (start-server #!key (port (server-port)) (ssl-context (server-ssl-context)) (bind-address (server-bind-address))) (parameterize ((load-verbose #f)) (letrec ((thread-count (make-mutex/value 'thread-count 0)) (listener (if ssl-context (ssl-listen port 4 bind-address ssl-context) (tcp-listen port 10 bind-address))) (accept-next-connection (lambda () (if (>= (mutex-specific thread-count) (max-connections)) (thread-yield!) ; Can't accept right now, wait & try again (receive (in out) (if ssl-context (ssl-accept listener) (tcp-accept listener)) (mutex-update! thread-count add1) (thread-start! (lambda () ;; thread-count _must_ be updated, so trap all exns (handle-exceptions e (void) (receive (local remote) (tcp-addresses in) (log-to (debug-log) "~A: incoming request from ~A" (thread-name (current-thread)) remote) ;; This won't change during the session (parameterize ((remote-address remote) (local-address local) (handle-another-request? #t)) (let handle-next-request () (when (handle-incoming-request in out) (log-to (debug-log) "~A: kept alive" (thread-name (current-thread))) (handle-next-request))) (log-to (debug-log) "~A: closing off" (thread-name (current-thread))) (close-input-port in) (close-output-port out)))) (mutex-update! thread-count sub1))))) (accept-next-connection)))) ;; Drop privileges ASAP, now the TCP listener has been created (switch-user/group (spiffy-user) (spiffy-group)) (accept-next-connection)))) )