;; ;; Spiffy the web server ;; ; Copyright (c) 2007-2010, 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 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? current-response current-file current-pathinfo server-software root-path server-port server-ssl-client-context server-ssl-pemfile server-ssl-keyfile 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 extras ports files data-structures) (require-extension srfi-1 srfi-13 srfi-14 srfi-18 tcp regex posix uri-common sendfile matchable) (require-library intarweb) (import (rename intarweb (headers intarweb:headers))) (define version 4) (define release 11) ;;; 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"))) ;; DEPRECATED (define server-ssl-client-context (make-parameter 'sslv2-or-v3)) (define server-ssl-pemfile (make-parameter #f)) (define server-ssl-keyfile (make-parameter #f)) ;; 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" . application/xml) ("pdf" . application/pdf) ("jpeg" . image/jpeg) ("jpg" . image/jpeg) ("gif" . image/gif) ("ico" . image/vnd.microsoft.icon) ("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)) (h (file-extension-handlers)) (handler (or (and ext (alist-ref ext h 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] \"~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 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 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 (file-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)))) ;; RFC 2616, 14.18: ;; "Origin servers MUST include a Date header field in all responses ;; [...] In theory, the date ought to represent the moment just before ;; the entity is generated." ;; So we do it here, as this is the very last moment where we're able ;; to get a current timestamp. (with-headers `((date #(,(seconds->utc-time (current-seconds))))) (lambda () (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"))) (send-response code: code reason: reason body: output headers: '((content-type text/html))))) (define (call-with-input-file* file proc) (call-with-input-file file (lambda (p) (handle-exceptions exn (begin (close-input-port p) (raise exn)) (proc p))))) (define (send-response #!key (code 200) (reason "OK") body (headers '())) (let ((new-headers (cons `(content-length ,(if body (string-length body) 0)) headers))) (parameterize ((current-response (update-response (current-response) code: code reason: reason headers: (intarweb:headers new-headers (response-headers (current-response)))))) (write-logged-response) (unless (or (eq? 'HEAD (request-method (current-request))) (not body)) (display body (response-port (current-response))))))) (define (send-static-file filename) (condition-case (let* ((path (make-pathname (root-path) filename)) (h (request-headers (current-request))) (size (file-size path)) (last-modified (file-modification-time path)) (etag (cons 'strong (conc size "-" last-modified))) (unmodified (or (and-let* ((t (header-values 'if-none-match h))) (etag-matches? etag t)) (and-let* ((t (header-value 'if-modified-since h))) (<= last-modified (utc-time->seconds t)))))) (with-headers `((last-modified #(,(seconds->utc-time last-modified))) (etag ,etag) (content-length ,(if unmodified 0 size)) (content-type ,(file-extension->mime-type (pathname-extension filename)))) (lambda () (if unmodified ;; RFC 2616, 10.3.5: ;; "The 304 response MUST NOT contain a message-body" ;; For this reason, we do not use send-status. (parameterize ((current-response (update-response (current-response) code: 304 reason: "Not modified"))) (write-logged-response)) (begin (write-logged-response) (unless (eq? 'HEAD (request-method (current-request))) (call-with-input-file* path (lambda (f) (sendfile f (response-port (current-response))))))))))) ((exn i/o file) (send-status 403 "Forbidden")))) (define (with-headers new-headers thunk) (parameterize ((current-response (update-response (current-response) headers: (intarweb: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 `(/ ,@(string-split (string-append path "/") "/") ""))) (with-headers `((location ,(update-uri (request-uri (current-request)) 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 (char-set #\/ #\nul)))) (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 () (if (null? remaining-path) (redirect-directory-root (make-pathname "/" current-path)) ;; Ignore empty path components like most ;; webservers do. It's slightly broken but ;; enough scripts generate bad URIs that it's ;; a useful thing to do. (maybe we shouldn't?) (let lp ((remaining-path remaining-path)) (cond ((null? remaining-path) (process-directory current-path)) ((string=? "" (car remaining-path)) (lp (cdr remaining-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 req) (let* ((uri (request-uri req)) (host-header (header-value 'host (request-headers req)))) (if (and (= (request-major req) 1) (>= (request-minor req) 1) (not host-header)) #f (or (and-let* ((host (uri-host uri)) (port (uri-port uri))) (cons host port)) host-header (cons (default-host) (server-port)))))) ;; Make the request uri a full uri including the host and port (define (normalize-uri req) (let ((uri (request-uri req))) (if (absolute-uri? uri) uri (let ((host&port (determine-vhost req)) (scheme (if (secure-connection?) 'https 'http))) (update-uri uri scheme: scheme host: (and host&port (car host&port)) port: (and host&port (cdr host&port))))))) (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 (update-request req uri: (normalize-uri req))) (current-response (make-response port: out headers: (intarweb: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* ((req-uri (request-uri (current-request))) (host (uri-host req-uri))) (if (and host (uri-path-absolute? (request-uri (current-request)))) (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 (uri-path req-uri))))) ;; Is this ok? ((handle-not-found) (uri-path req-uri)))) ;; 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

")) (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))))) ;; From the openssl egg. This is a way to support SSL without *requiring* it. (define (ssl-port? obj) (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket))) (define (ssl-port->tcp-port p) (if (ssl-port? p) (##sys#slot p 11) (error "Expected an SSL port"))) (define (accept-loop listener accept) (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)")) (debug! (lambda (m . args) (apply log-to (debug-log) (conc "~A: " m) (thread-name (current-thread)) args)))) (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) (tcp-addresses (if (ssl-port? in) (ssl-port->tcp-port in) in)))) (debug! "Incoming request from ~A" remote) (mutex-update! thread-count add1) (thread-start! (lambda () ;; thread-count _must_ be updated, so trap all exns (handle-exceptions e (debug! "Uncaught exception: ~S (SHOULD NOT HAPPEN!)" (exn-message e)) ;; This won't change during the session (parameterize ((remote-address remote) (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 (handle-incoming-request in 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)) ssl-client-context ; Deprecated (ssl-pemfile (server-ssl-pemfile)) ; Deprecated (ssl-keyfile (server-ssl-keyfile)) ; Deprecated (bind-address (server-bind-address)) (listen tcp-listen) (accept tcp-accept)) (when (or ssl-client-context ssl-pemfile ssl-keyfile) (error (conc "ssl-client-context, ssl-pemfile and ssl-keyfile are no " "longer directly supported by start-server in order to make " "Spiffy independent of the openssl egg. See the spiffy " "manual wiki page for info on how to use SSL."))) (let ((listener (listen port 10 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)))) )