;; ;; Spiffy the web server ;; ; Copyright (c) 2007-2014, 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 (module spiffy (start-server switch-user/group accept-loop with-headers send-status send-response send-static-file log-to write-logged-response build-error-message current-request local-address remote-address secure-connection? trusted-proxies current-response current-file current-pathinfo server-software root-path server-port server-bind-address index-files mime-type-map default-mime-type file-extension->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) (use extras ports files data-structures srfi-1 srfi-13 srfi-14 srfi-18 tcp posix irregex uri-common sendfile (rename intarweb (headers intarweb:headers))) (define version 5) (define release 4) ;;; 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)) (define secure-connection? (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-bind-address (make-parameter #f)) (define index-files (make-parameter '("index.html" "index.xhtml"))) (define trusted-proxies (make-parameter '())) ;; See http://www.iana.org/assignments/media-types/ for a full list ;; with links to RFCs describing the gory details. (define mime-type-map (make-parameter '(("html" . text/html) ("xhtml" . application/xhtml+xml) ("js" . application/javascript) ("css" . text/css) ("png" . image/png) ;; A charset parameter is STRONGLY RECOMMENDED by RFC 3023 but it overrides ;; document declarations, so don't supply it (assume nothing about files) ("xml" . application/xml) ;; Use text/xml only if it is *truly* human-readable (eg docbook, recipe...) #;("xml" . text/xml) ("pdf" . application/pdf) ("jpeg" . image/jpeg) ("jpg" . image/jpeg) ("gif" . image/gif) ("ico" . image/vnd.microsoft.icon) ("svg" . image/svg+xml) ("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 'forbidden)))) ;; TODO: maybe simplify this so it falls into more reusable pieces (define handle-file (make-parameter (lambda (path) (let* ((ext (pathname-extension path)) (h (file-extension-handlers)) (m '(HEAD GET)) (handler (or (and ext (alist-ref ext h string-ci=?)) (lambda (fn) ;; Check here for allowed methods, because ;; for example a .cgi handler might allow POST, ;; and anyone can re-use send-static-file to ;; send a file even when another method is used. (if (not (memq (request-method (current-request)) m)) (with-headers `((allow . ,m)) (lambda () (send-status 'method-not-allowed))) (send-static-file fn)))))) (handler path))))) (define handle-not-found (make-parameter (lambda (path) (send-status 'not-found "
The resource you requested could not be found
")))) (define handle-exception (make-parameter (lambda (exn chain) (log-to (error-log) "[~A] \"~A ~A HTTP/~A.~A\" ~A" (seconds->string (current-seconds)) (request-method (current-request)) (uri->string (request-uri (current-request))) (request-major (current-request)) (request-minor (current-request)) (build-error-message exn chain #t)) (send-status '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 () (and-let* ((logfile (access-log)) (h (request-headers (current-request)))) (log-to logfile "~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 ((ua (header-contents 'user-agent h))) (if ua (software-unparser ua) "**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)))) ;; Handy shortcut for logging to the debug log with the current ;; thread name prefixed to the log. (define (debug! m . args) (apply log-to (debug-log) (conc "~A: " m) (thread-name (current-thread)) args)) (define build-error-message (let* ((cpa condition-property-accessor) (exn-message (cpa 'exn 'message "(no message)")) (exn-location (cpa 'exn 'location "*ERROR LOCATION UNKNOWN*")) (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
"))) (unless (##sys#slot out 8) ;; port-closed? (flush-output out)) (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)) ;; Check whether the mutex has the correct state. If not, wait for a condition ;; and try again (define (mutex-wait! m ok? condition) (let retry () (mutex-lock! m) (if (ok? (mutex-specific m)) (mutex-unlock! m) (begin (mutex-unlock! m condition) (retry))))) ;; Imports from the openssl egg, if available (define (dynamic-import module symbol default) (handle-exceptions _ default (eval `(let () (use ,module) ,symbol)))) (define ssl-port? (dynamic-import 'openssl 'ssl-port? (lambda (v) #f))) (define ssl-port->tcp-port (dynamic-import 'openssl 'ssl-port->tcp-port (lambda (v) (error 'ssl-port->tcp-port "Expected an SSL port" v)))) (define (ssl-or-tcp-addresses p) (tcp-addresses (if (ssl-port? p) (ssl-port->tcp-port p) p))) (define (accept-loop listener accept #!optional (addresses ssl-or-tcp-addresses)) (let ((thread-count (make-mutex/value 'thread-count 0)) (thread-stopped! (make-condition-variable 'thread-stopped!)) (exn-message (condition-property-accessor 'exn 'message "(no message)"))) (let accept-next-connection () ;; Wait until we have a free connection slot (mutex-wait! thread-count (lambda (count) (< count (max-connections))) thread-stopped!) (handle-exceptions ; Catch errors during TCP/SSL handshake e (debug! "Connection handshake error: ~S" (exn-message e)) (let*-values (((in out) (accept listener)) ((local remote) (addresses in))) (mutex-update! thread-count add1) (thread-start! (lambda () (debug! "Incoming request from ~A" remote) ;; thread-count _must_ be updated, so trap all exns (handle-exceptions e (debug! "Uncaught exception: ~S (SHOULD NOT HAPPEN!)" (exn-message e)) ;; Most of these won't change during the session. ;; Some may be refined using info from headers after parsing (parameterize ((remote-address remote) ; Initial value (local-address local) ;; Believe the user when (s)he says it's a ;; secure connection. Otherwise try to ;; detect it by checking for an SSL port. (secure-connection? (or (secure-connection?) (ssl-port? in))) (handle-another-request? #t) (load-verbose #f)) (let handle-next-request () (when (and (handle-incoming-request in out) (not (port-closed? in)) (not (port-closed? out))) (debug! "Kept alive") (handle-next-request))) (debug! "Closing off") (close-input-port in) (close-output-port out))) (mutex-update! thread-count sub1) ;; Wake up the accepting thread if it's asleep (condition-variable-signal! thread-stopped!))))) (accept-next-connection)))) (define (start-server #!key (port (server-port)) (bind-address (server-bind-address)) (listen tcp-listen) (accept tcp-accept) (addresses ssl-or-tcp-addresses)) (let ((listener (listen port 100 bind-address))) ;; Drop privileges ASAP, now the TCP listener has been created (switch-user/group (spiffy-user) (spiffy-group)) ;; Make these parameters actual (start-server arg might override it) (parameterize ((server-port port) (server-bind-address bind-address)) (accept-loop listener accept addresses)))) )