;; ;; 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 "

")) (display "Error:") (and-let* ((loc (exn-location exn))) (if raw-output (printf " (~A)" (->string loc)) (printf " (~A)" (htmlize (->string loc))))) (if raw-output (printf "\n~A\n" (exn-message exn)) (printf "

\n

~A

\n" (htmlize (exn-message exn)))) (unless (null? (exn-arguments exn)) (unless raw-output (printf ""))) (if raw-output (print chain) (printf "
~a
" (htmlize chain)))) (begin (##sys#with-print-length-limit 120 (lambda () (if raw-output (printf "Uncaught exception:\n~S\n" exn) (printf "

Uncaught exception:

\n~S\n" exn))))))))))) (define (extension->mime-type ext) (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type))) (define handle-another-request? (make-parameter #f)) ;; Internal parameter (define (write-logged-response) ((handle-access-logging)) (handle-another-request? (and (keep-alive? (current-request)) (keep-alive? (current-response)))) (write-response (current-response))) ;; A simple utility procedure to render a status code with message (define (send-status code reason #!optional (text "")) (let* ((htmlized-reason (htmlize reason)) (output (conc "\n" "\n" "\n" " \n" " " code " - " htmlized-reason "\n" " \n" " \n" "

" code " - " htmlized-reason "

\n" text "\n" ; *not* htmlized, so this can contain HTML " \n" "\n"))) (parameterize ((current-response (update-response (current-response) code: code reason: reason headers: (headers `((content-type text/html) (content-length ,(string-length output))) (response-headers (current-response)))))) (write-logged-response) (display output (response-port (current-response)))))) (define (send-static-file filename) (condition-case (let* ((path (make-pathname (root-path) filename)) (fd (file-open path (+ open/binary open/rdonly)))) (with-headers `((content-length ,(file-size path)) (content-type ,(extension->mime-type (pathname-extension filename)))) (lambda () (write-logged-response) (handle-exceptions exn (begin (file-close fd) (signal exn)) (sendfile fd (response-port (current-response)))) (file-close fd)))) ((exn i/o file) (send-status 403 "Forbidden")))) (define (with-headers new-headers thunk) (parameterize ((current-response (update-response (current-response) headers: (headers new-headers (response-headers (current-response)))))) (thunk))) (define (process-directory path) (let ((index-page (find (lambda (ip) (file-exists? (make-pathname (list (root-path) path) ip))) (index-files)))) (if index-page (process-entry path index-page '()) ((handle-directory) (make-pathname "/" path))))) ;; If an URL is missing a trailing slash, instead of directly serving ;; its index-file, redirect to the URL _with_ trailing slash. This ;; prevents problems with relative references since the directory ;; would be seen as the file component in the path and get replaced. (define (redirect-directory-root path) (let ((new-path (uri-path (uri-reference (string-append path "/"))))) (with-headers `((location ,(update-uri (server-root-uri) path: new-path))) (lambda () (send-status 301 "Moved permanently"))))) (define (apply-access-file path continue) (let ((file (make-pathname path (access-file)))) (if (and (access-file) (file-exists? file)) ((eval (call-with-input-file file read)) continue) (continue)))) ;; Is the file impossible to be requested directly? ;; ;; Any file that the the filesystem is incapable of representing is ;; considered impossible to request. This includes files with a name that ;; includes a slash, and "." and ".." because they are special files. ;; If this is requested, it's probably an encoded traversal attack (define (impossible-filename? name) (or (string=? name ".") (string=? name "..") (string-index name #\/))) (define (process-entry previous-path fragment remaining-path) (let* ((current-path (make-pathname previous-path fragment)) (full-path (make-pathname (root-path) current-path))) (cond ((impossible-filename? fragment) ((handle-not-found) (make-pathname "/" current-path))) ((directory? full-path) (apply-access-file full-path (lambda () (match remaining-path (() (redirect-directory-root (make-pathname "/" current-path))) (("") (process-directory current-path)) (else (process-entry current-path (car remaining-path) (cdr remaining-path))))))) ((file-exists? full-path) (parameterize ((current-pathinfo remaining-path) (current-file (make-pathname "/" current-path))) ((handle-file) (current-file)))) ;; hmm, not too useful (else ((handle-not-found) (make-pathname "/" current-path)))))) ;; Determine the vhost and port to use. This follows RFC 2616, section 5.2: ;; If request URL is absolute, use that. Otherwise, look at the Host header. ;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of ;; RFC 2616. If no host line is present, it returns the default host ;; for HTTP/1.0. (define (determine-vhost) (let* ((request-uri (request-uri (current-request))) (host-header (header-value 'host (request-headers (current-request))))) (if (and (= (request-major (current-request)) 1) (>= (request-minor (current-request)) 1) (not host-header)) #f (or (uri-host request-uri) (if host-header (car host-header) (default-host)))))) (define (server-root-uri) (let ((uri (request-uri (current-request)))) (if (absolute-uri? uri) uri (let ((host (determine-vhost)) (scheme 'http) ; find out the scheme from port if https is allowed (port (server-port))) (update-uri uri scheme: scheme port: port host: host))))) (define request-restarter (make-parameter #f)) ; Internal parameter (define (restart-request req) ((request-restarter) req (request-restarter))) (define (handle-incoming-request in out) (handle-exceptions exn ; This should probably be more fine-grained (begin (close-input-port in) (close-output-port out) #f) ; Do not keep going (receive (req cont) (call/cc (lambda (c) (values (read-request in) c))) (parameterize ((current-request req) (current-response (make-response port: out headers: (headers `((content-type text/html) (server ,(server-software)))))) (request-restarter cont)) (handle-exceptions exn (begin ((handle-exception) exn (with-output-to-string print-call-chain)) #f) ; Do not keep going (let ((path (uri-path (request-uri req))) (host (determine-vhost))) (if (and host (pair? path) ;; XXX change this to absolute-path? (eq? (car path) '/)) (let ((handler (alist-ref host (vhost-map) (lambda (h _) (if (not (regexp? h)) (string-match (regexp h #t) host) (string-match h host)))))) (if handler (handler (lambda () (process-entry "" "" (cdr path)))) ;; Is this ok? ((handle-not-found) path))) ;; No host or non-absolute URI in the request is an error. (send-status 400 "Bad request" "

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)))) )