;; ;; Spiffy the web server ;; ; Copyright (c) 2007-2015, 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 "

")) (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)))) (let ((args (exn-arguments exn))) (unless (null? args) (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 ;; TODO: This is a bit ugly and should be rewritten to be simpler. (define (send-status st #!optional reason-or-text text) (let*-values (((status) (if (symbol? st) st (response-status st))) ((code status-reason) (http-status->code&reason status)) ((reason) (if (symbol? st) status-reason reason-or-text)) ((htmlized-reason) (htmlize reason)) ((message) (or (if (symbol? st) reason-or-text text) "")) ((output) (conc "\n" "\n" "\n" " \n" " " code " - " htmlized-reason "\n" " \n" " \n" "

" code " - " htmlized-reason "

\n" " " message "\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))) #:binary)) (define (send-response #!key code reason status body (headers '())) (let* ((new-headers (cons `(content-length ,(if body (string-length body) 0)) headers)) (h (intarweb:headers new-headers (response-headers (current-response)))) (resp (if (and status (not code) (not reason)) (update-response (current-response) status: status headers: h) (update-response (current-response) code: (or code 200) reason: (or reason "OK") headers: h))) (req (current-request))) (parameterize ((current-response resp)) (write-logged-response) (when (and body ((response-has-message-body-for-request?) resp req)) (display body (response-port resp)) (finish-response-body resp))))) (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)))))) (parameterize ((current-response (if unmodified (update-response (current-response) status: 'not-modified) (current-response)))) (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 () (call-with-input-file* path (lambda (f) (write-logged-response) (when ((response-has-message-body-for-request?) (current-response) (current-request)) (sendfile f (response-port (current-response)))))))))) ((exn i/o file) (send-status '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 '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 ".", "..", and ;; files with a name containing a NUL or a slash; they are all special ;; files. Such a request is probably an encoded traversal attack. ;; ;; Please note that we disallow backslash even in a UNIX environment, ;; because core plays fast and loose with slashes and backslashes. ;; This causes the path "\.." (which strictly speaking is 100% ;; harmless on UNIX) to be converted to "/..", which opens up a path ;; traversal bug! So as a workaround we add the backslash in all ;; cases. Because backslashes in filenames are relatively rare, ;; hopefully this causes no additional problems... This vulnerability ;; was found by Benedikt Rosenau with the Netsparker vulnerability ;; scanner. In fixed CHICKENs we should deny the backslash only on ;; Windows. (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) (debug! "Restarting request from ~A (with uri: ~A)" (remote-address) (request-uri req)) ((request-restarter) req (request-restarter))) (define (determine-remote-address-with-trusted-proxies req) ;; If the remote end is untrusted, that's the remote address. If it ;; is trusted, see for whom it forwarded the request and loop. Take ;; care to stop on a trusted host if there are no more forwarded-for ;; entries (a request may originate from a trusted host). (let lp ((address-chain (cons (remote-address) (reverse (header-values 'x-forwarded-for (request-headers req)))))) (if (and (member (car address-chain) (trusted-proxies)) (not (null? (cdr address-chain)))) (lp (cdr address-chain)) (car address-chain)))) (define (handle-incoming-request in out) (handle-exceptions exn ; This should probably be more fine-grained (let ((chain (with-output-to-string print-call-chain))) (close-input-port in) (close-output-port out) (debug! "~A" (build-error-message exn chain #t)) #f) ; Do not keep going (receive (req cont) (call/cc (lambda (c) (values (read-request in) c))) (and req ; No request? Then the connection was closed. Don't keep going. (parameterize ((remote-address (determine-remote-address-with-trusted-proxies req)) (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)) (debug! "Handling request from ~A" (remote-address)) (handle-exceptions exn (begin ((handle-exception) exn (with-output-to-string print-call-chain)) #f) ; Do not keep going (let ((host (uri-host (request-uri (current-request))))) (if (and host (uri-path-absolute? (request-uri (current-request)))) (let ((handler (alist-ref host (vhost-map) (lambda (h _) (irregex-match (irregex h 'i) host))))) (if handler (handler (lambda () (process-entry "" "" (cdr (uri-path (request-uri (current-request))))))) ;; Is this ok? ((handle-not-found) (uri-path (request-uri (current-request)))))) ;; No host or non-absolute URI in the request is an error. (send-status 'bad-request (conc "

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-inline (spiffy-thread-start! thunk) (thread-start! (make-thread thunk (gensym 'spiffy)))) (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) (spiffy-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)))) )