summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--simple-directory-handler.scm108
-rw-r--r--spiffy.egg12
-rw-r--r--spiffy.scm667
-rw-r--r--tests/run.scm287
-rw-r--r--tests/testlib.scm108
-rw-r--r--tests/testweb/data1
-rw-r--r--tests/testweb/denied.txt1
-rw-r--r--tests/testweb/hello.txt1
-rw-r--r--tests/testweb/index.html15
-rw-r--r--tests/testweb/once.scm2
-rw-r--r--tests/testweb/pics/chicken-logo.pngbin0 -> 24679 bytes
-rw-r--r--tests/testweb/pics/lambda-chicken.gifbin0 -> 1050 bytes
-rw-r--r--tests/testweb/secrets/bank/pin-code.txt1
-rw-r--r--tests/testweb/secrets/password.txt1
-rw-r--r--tests/testweb/secrets/spiffy-access5
-rw-r--r--tests/testweb/spiffy-access4
-rw-r--r--tests/testweb/subdir with space/index.html14
-rw-r--r--tests/testweb/subdir/index.html15
-rw-r--r--tests/testweb/subdir/spiffy-access4
-rw-r--r--tests/testweb/subdir/subsubdir/index.html15
-rw-r--r--tests/testweb/test.myscript1
21 files changed, 1262 insertions, 0 deletions
diff --git a/simple-directory-handler.scm b/simple-directory-handler.scm
new file mode 100644
index 0000000..c232478
--- /dev/null
+++ b/simple-directory-handler.scm
@@ -0,0 +1,108 @@
+;;;; simple-directory-handler.scm
+;
+; Copyright (c) 2007-2009, 2012, 2018, 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.
+
+(module simple-directory-handler
+ (simple-directory-handler simple-directory-dotfiles?
+ simple-directory-display-file)
+
+(import scheme (chicken base) (chicken condition) (chicken time posix)
+ (chicken file posix) (chicken pathname) (chicken format)
+ (chicken file) (only srfi-1 fold) (only (chicken sort) sort)
+ intarweb spiffy)
+
+(define simple-directory-dotfiles? (make-parameter #f))
+(define simple-directory-display-file
+ (make-parameter
+ (lambda (remote-file local-file dir?)
+ (sprintf "<tr>
+ <td><a href=\"~a\">~a</a></td>
+ <td>~a</td>
+ <td>~a</td>
+ </tr>\n"
+ (htmlize remote-file)
+ (string-append (htmlize (pathname-strip-directory remote-file))
+ (if dir? "/" "")) ; a small hint that it's a dir
+ (file-size local-file)
+ (seconds->string (file-modification-time local-file))))))
+
+(define (simple-directory-handler path)
+ (let ([str
+ (sprintf
+ "<!DOCTYPE html PUBLIC
+ \"-//W3C//DTD XHTML 1.0 Strict//EN\"
+ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
+<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">
+ <head>
+ <title>Index of ~a</title>
+ </head>
+ <body>
+ <h1>Index of ~a:</h1>
+ <p><a href=\"~a\">Go to parent directory</a></p>
+ <table>
+ <thead>
+ <tr>
+ <th>Name</th>
+ <th>Size</th>
+ <th>Last modified</th>
+ </tr>
+ </thead>
+ <tbody>~a</tbody>
+ </table>
+ </body>
+</html>"
+ path
+ path
+ (or (pathname-directory path) path)
+ (let ([dir (sort (directory (make-pathname (root-path) path)
+ (simple-directory-dotfiles?))
+ string<?)])
+ (fold
+ (lambda (file str)
+ (let* ((local-file (make-pathname (list (root-path) path)
+ file))
+ (remote-file (make-pathname path file))
+ (dir? (directory? local-file)))
+ (condition-case
+ (string-append str ((simple-directory-display-file)
+ remote-file local-file dir?))
+ ;; Race condition: file might have been deleted or might be
+ ;; otherwise inaccessible (#939; self-referential symlink)
+ ((exn i/o file) str))))
+ ""
+ dir)))])
+ (with-headers `((content-type text/html)
+ (content-length ,(string-length str)))
+ (lambda ()
+ (write-logged-response)
+ (unless (eq? 'HEAD (request-method (current-request)))
+ (display str (response-port (current-response))))))))
+)
diff --git a/spiffy.egg b/spiffy.egg
new file mode 100644
index 0000000..31940ce
--- /dev/null
+++ b/spiffy.egg
@@ -0,0 +1,12 @@
+;;; -*- Scheme -*-
+
+((synopsis "A small but powerful web server")
+ (author "Felix Winkelmann")
+ (maintainer "Peter Bex")
+ (category web)
+ (license "BSD")
+ (dependencies intarweb uri-common uri-generic sendfile posix-groups
+ srfi-1 srfi-13 srfi-14 srfi-18)
+ (test-dependencies test)
+ (components (extension spiffy (csc-options "-O3"))
+ (extension simple-directory-handler (csc-options "-O3"))))
diff --git a/spiffy.scm b/spiffy.scm
new file mode 100644
index 0000000..91e6bee
--- /dev/null
+++ b/spiffy.scm
@@ -0,0 +1,667 @@
+;;
+;; Spiffy the web server
+;;
+; Copyright (c) 2007-2017, 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 scheme (chicken base) (chicken file) (chicken port)
+ (chicken string) (chicken tcp) (chicken irregex)
+ (chicken pathname) (chicken platform) (chicken format)
+ (chicken time) (chicken time posix) (chicken condition)
+ (chicken file posix) (chicken process signal) (chicken load)
+ (chicken process-context) (chicken process-context posix)
+ srfi-1 srfi-13 srfi-14 srfi-18
+ posix-groups uri-common sendfile
+ (rename intarweb (headers intarweb:headers)))
+
+(define version 6)
+(define release 0)
+
+;;; 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
+ "<p>The resource you requested could not be found</p>"))))
+(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 "<h2>"))
+ (display "Error:")
+ (and-let* ((loc (exn-location exn)))
+ (if raw-output
+ (printf " (~A)" (->string loc))
+ (printf " (<em>~A</em>)" (htmlize (->string loc)))))
+ (if raw-output
+ (printf "\n~A\n" (exn-message exn))
+ (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn))))
+ (let ((args (exn-arguments exn)))
+ (unless (null? args)
+ (unless raw-output (printf "<ul>"))
+ (for-each
+ (lambda (a)
+ (##sys#with-print-length-limit
+ 120
+ (lambda ()
+ (if raw-output
+ (printf "~S~%" a)
+ (printf "<li>~A</li>"
+ (htmlize (format "~S" a)))))))
+ ;; Workaround for truly broken libraries (like intarweb)
+ ;; which don't pass lists in the 'arguments property
+ (if (list? args) args (list args)))
+ (unless raw-output
+ (printf "</ul>"))))
+ (if raw-output
+ (print chain)
+ (printf "<pre>~a</pre>" (htmlize chain))))
+ (begin
+ (##sys#with-print-length-limit
+ 120
+ (lambda ()
+ (if raw-output
+ (printf "Uncaught exception:\n~S\n" exn)
+ (printf "<h2>Uncaught exception:</h2>\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 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
+ "<!DOCTYPE html\n"
+ " PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n"
+ " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"
+ "<html xmlns=\"http://www.w3.org/1999/xhtml\"\n"
+ " xml:lang=\"en\" lang=\"en\">\n"
+ " <head>\n"
+ " <title>" code " - " htmlized-reason "</title>\n"
+ " </head>\n"
+ " <body>\n"
+ " <h1>" code " - " htmlized-reason "</h1>\n"
+ " " message "\n" ; *not* htmlized, so this can contain HTML
+ " </body>\n"
+ "</html>\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 we work around this by adding a backslash to
+;; invalid-set on UNIX as well. Because backslashes in filenames are
+;; relatively rare, this won't cause too many additional problems...
+;; This vulnerability was found by Benedikt Rosenau with the
+;; Netsparker vulnerability scanner.
+(define impossible-filename?
+ (let ((invalid-set (if (or ##sys#windows-platform
+ ;; This detects CHICKENs with the bug
+ (string=? (make-pathname "/" "\\") "/"))
+ (char-set #\\ #\/ #\nul)
+ (char-set #\/ #\nul))))
+ (lambda (name)
+ (or (string=? name ".") (string=? name "..")
+ (string-index name invalid-set)))))
+
+(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 compiled-vhost-map 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 ((ir&handler
+ (assoc host compiled-vhost-map
+ (lambda (host ir)
+ (irregex-match ir host)))))
+ (if ir&handler
+ ((cdr ir&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 "<p>Your client sent a request that "
+ "the server did not understand</p>")))
+ (unless (##sys#slot out 8) ;; port-closed?
+ (flush-output out))
+ (handle-another-request?)))))))) ; Keep going?
+
+(define (htmlize str)
+ (string-translate* str '(("<" . "&lt;") (">" . "&gt;")
+ ("\"" . "&quot;") ("'" . "&#x27;") ("&" . "&amp;"))))
+
+;; 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))
+ (set-environment-variable! "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 () (import ,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)"))
+ (compiled-vhost-map
+ (map (lambda (irregex&handler)
+ (cons (irregex (car irregex&handler) 'i)
+ (cdr irregex&handler)))
+ (vhost-map))))
+ (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
+ compiled-vhost-map 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))))
+
+)
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..722d6e3
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,287 @@
+(import test (chicken irregex) (chicken time) (chicken time posix)
+ (chicken file) intarweb)
+
+;; Change this to (use spiffy) when compiling tests
+(load "../spiffy.scm")
+(import spiffy)
+
+(test-begin "spiffy")
+
+(include "testlib.scm")
+
+(define noway "No way, Jose!")
+
+(with-output-to-file "root-counter" (lambda () (write 0)))
+(with-output-to-file "counter" (lambda () (write 0)))
+
+(define (myscript-handler path)
+ (write-logged-response)
+ (display "script!" (response-port (current-response))))
+
+(parameterize
+ ((default-mime-type 'application/unknown)
+ (handle-directory (lambda (p) (send-string/code 403 "Forbidden" "forbidden")))
+ (file-extension-handlers `(("myscript" . ,myscript-handler)))
+ (access-file "spiffy-access")
+ (trusted-proxies '("127.0.0.1" "10.0.0.1"))
+ (vhost-map
+ `(("foohost" . , (lambda (continue)
+ (parameterize ((current-request
+ (update-request
+ (current-request)
+ uri: (update-uri
+ (request-uri (current-request))
+ path: '(/ "hello.txt")))))
+ (continue))))
+ (,(irregex "testhost.*") . ,(lambda (continue)
+ (continue)))
+ ("redirect-host" . ,(lambda (continue)
+ (with-headers
+ `((location ,(update-uri
+ (request-uri (current-request))
+ path: '(/ "move-along"))))
+ (lambda ()
+ (send-status 303 "Moved")))))
+ ("error-host" . ,(lambda (continue)
+ (error "This should give a 500 error")))
+ ("unknown-length-host" . ,(lambda (continue)
+ (write-logged-response)
+ (let ((p (response-port (current-response))))
+ (display "foo" p)
+ (close-output-port p))))
+ ("subdir-host" . ,(lambda (continue)
+ (parameterize ((root-path "./testweb/subdir"))
+ (continue))))
+ ("ip-host" . ,(lambda (continue)
+ (send-string/code 200 "OK" (remote-address)))))))
+ (start-spiffy))
+
+(define hello.txt (with-input-from-file "testweb/hello.txt" read-string))
+
+(test-begin "vhost support")
+(test-response "String match" (200 hello.txt) "/hello.txt" "foohost")
+(test-response "String case insensitivity" (200 hello.txt)
+ "/hello.txt" "FOOHOST")
+(test-response "URI override works" (200 hello.txt) "/index.html" "foohost")
+(test-response "Regexp match" (200 hello.txt) "/hello.txt" "testhost")
+(test-response "Regexp case sensitivity" (404 NOT-FOUND) "/hello.txt" "TESTHOST")
+(test-response "Nonexistent host name" (404 NOT-FOUND)
+ "/hello.txt" "call-with-previous-continuation.org")
+(test-response "No host on HTTP/1.0 works" (200 hello.txt)
+ "/hello.txt" "foohost" send-headers: '())
+(test-response "No host on HTTP/1.1 gives error" 400
+ "/hello.txt" "foohost" send-headers: '() version: '(1 1)
+ absolute-uri: #f)
+(test-end "vhost support")
+
+(define chicken-logo.png (with-input-from-file "testweb/pics/chicken-logo.png" read-string))
+(define lambda-chicken.gif (with-input-from-file "testweb/pics/lambda-chicken.gif" read-string))
+(define index.html (with-input-from-file "testweb/index.html" read-string))
+(define index-subdir (with-input-from-file "testweb/subdir/index.html" read-string))
+(define index-subsubdir (with-input-from-file "testweb/subdir/subsubdir/index.html" read-string))
+(define index-subdir-with-space (with-input-from-file "testweb/subdir with space/index.html" read-string))
+
+
+(test-begin "static file serving")
+(test-response "Nonexistant file" (404 NOT-FOUND)
+ "/bogus" "testhost")
+(unless (zero? (current-user-id)) ; Root can read even unreadable files :)
+ (let ((old-perm (file-permissions "testweb/denied.txt")))
+ (set-file-permissions! "testweb/denied.txt" 0)
+ (test-response "Forbidden file" 403 "/denied.txt" "testhost")
+ (set-file-permissions! "testweb/denied.txt" old-perm)))
+(test-header "Nonexistant file mimetype" content-type (text/html)
+ "/bogus" "testhost")
+(test-response "Nonexistant file with extension" (404 NOT-FOUND)
+ "/bogus.gif" "testhost")
+(test-header "Nonexistant file with extension mimetype" content-type (text/html)
+ "/bogus.gif" "testhost")
+(test-header "text/plain mimetype" content-type (text/plain)
+ "/hello.txt" "testhost")
+(test-header "image/gif mimetype" content-type (image/gif)
+ "/pics/lambda-chicken.gif" "testhost")
+(test-response "image/gif contents" (200 lambda-chicken.gif)
+ "/pics/lambda-chicken.gif" "testhost")
+(test-header "image/png mimetype" content-type (image/png)
+ "/pics/chicken-logo.png" "testhost")
+(test-response "image/png contents" (200 chicken-logo.png)
+ "/pics/chicken-logo.png" "testhost")
+(test-header "unknown mimetype" content-type (application/unknown)
+ "/data" "testhost")
+(test-response "'Moved Permanently' on directory" 301 "/pics" "testhost")
+(test-header "location URI is absolute" location
+ (,(testserver-uri "http://testhost/pics/"))
+ "/pics" "testhost" absolute-uri: #f)
+(test-response "directory listing denied" (403 "forbidden")
+ "/pics/" "testhost")
+(test-response "non-GET/HEAD method disallowed" 405
+ "/hello.txt" "testhost" method: 'PUT)
+(test-header "non-GET/HEAD method Allow header present" allow (HEAD GET)
+ "/hello.txt" "testhost" method: 'PUT)
+(test-end "static file serving")
+
+(test-begin "path normalization")
+(test-header "index page redir" location
+ (,(testserver-uri "http://testhost/subdir%20with%20space/"))
+ "/subdir%20with%20space" "testhost")
+(test-header "index page redir preserves GET args" location
+ (,(testserver-uri "http://testhost/subdir%20with%20space/?foo=bar"))
+ "/subdir%20with%20space?foo=bar" "testhost")
+(test-response "index page redir status" 301
+ "/subdir%20with%20space" "testhost")
+(test-response "index page" (200 index-subdir-with-space)
+ "/subdir%20with%20space/" "testhost")
+(test-response "break out of webroot fails" (200 index-subdir)
+ "/subdir/../../subdir/" "testhost")
+;; This doesn't work because it's not accepted by uri-common. One
+;; could send it raw on the HTTP line, but it wouldn't be accepted
+;; either. Still, it would be good to actually test for this!
+#;(test-response "break out of webroot fails w/ backslash"
+ (400 index-subdir) "/subdir\\..\\../subdir/" "testhost")
+(test-response "index page in subdir vhost" (200 index-subdir)
+ "/" "subdir-host")
+(test-header "index page redir for subdir vhost" location
+ (,(testserver-uri "http://subdir-host/subsubdir/"))
+ "/subsubdir" "subdir-host")
+(test-response "index page redir status for subdir vhost" 301
+ "/subsubdir" "subdir-host")
+(test-response "index page in subdir for subdir vhost" (200 index-subsubdir)
+ "/subsubdir/" "subdir-host")
+(test-response "break out of vhost webroot gives index of root"
+ (200 index-subsubdir)
+ "/subsubdir/../../subsubdir/" "subdir-host")
+;; Same as above
+#;(test-response "break out of vhost webroot fails w/ backslash"
+ (200 index-subsubdir)
+ "/subsubdir\\..\\../subsubdir/" "subdir-host")
+(test-response "break out of vhost webroot fails w/ backslash" 404
+ "/subsubdir%5C..%5C../subsubdir/" "subdir-host")
+(test-response "break out of vhost webroot fails" (404 NOT-FOUND)
+ "/../hello.txt" "subdir-host")
+;; Once again
+#;(test-response "break out of vhost webroot w/ backslash fails"
+ (404 NOT-FOUND)
+ "\\..\\hello.txt" "subdir-host")
+;; But we *can* test it with an encoded backslash
+(test-response "break out of vhost webroot w/ backslash fails"
+ (404 NOT-FOUND)
+ "/%5C../hello.txt" "subdir-host")
+(test-response "Null-terminated filename fails" (404 NOT-FOUND)
+ "/hello.txt%00xyz" "testhost")
+(test-response "encoded break out of vhost webroot fails" (404 NOT-FOUND)
+ "/%2e%2e%2fhello.txt" "subdir-host")
+(test-response "encoded break out of vhost webroot fails w/ backslash"
+ (404 NOT-FOUND)
+ "/%5c%2e%2e/hello.txt" "subdir-host")
+(test-end "path normalization")
+
+(test-begin "access files")
+(with-output-to-file "root-counter" (lambda () (write 0)))
+(test-response "Webroot" (200 index.html) "/" "testhost")
+(test "After webroot, root-counter is 1"
+ 1 (with-input-from-file "root-counter" read))
+(with-output-to-file "counter" (lambda () (write 0)))
+(test-response "Two slashes" (200 index-subdir) "/subdir//" "testhost")
+(test "After two slashes, counter is 1"
+ 1 (with-input-from-file "counter" read))
+(test "After webroot and two slashes, root-counter is 2"
+ 2 (with-input-from-file "root-counter" read))
+(test-response "Dir request" (200 noway)
+ "/secrets" "testhost") ;; Access file applies on dir and all below
+(test-response "File request in dir" (200 noway)
+ "/secrets/password.txt" "testhost")
+(test-response "Subdir request" (200 noway)
+ "/secrets/bank" "testhost")
+(test-response "File request in subdir" (200 noway)
+ "/secrets/bank/pin-code.txt" "testhost")
+(test-end "access files")
+
+(test-begin "miscellaneous")
+(test-response "custom extension handlers" (200 "script!")
+ "/test.myscript" "testhost")
+(test-response "redirect" 303 "/blah" "redirect-host")
+(test-header "redirect location" location
+ (,(testserver-uri "http://redirect-host/move-along"))
+ "/blah" "redirect-host")
+(test-header "redirect for simulated proxy (other port)" location
+ ;; This uri is an absolute reference elsewhere, NOT on
+ ;; the test server!
+ (,(uri-reference "http://redirect-host:8081/move-along"))
+ "/blah" "redirect-host"
+ send-headers: `((host ("redirect-host" . 8081))) absolute-uri: #f)
+;; The exception handler in testlib just dumps the message in response
+(test-response "internal error" (500 "This should give a 500 error")
+ "/cause-error" "error-host")
+(test-response "Variable length (no content-length header)" (200 "foo")
+ "/whatever" "unknown-length-host")
+(test-assert "Variable length didn't cause error after response was sent" (not response-error?))
+
+;; We're spoofing forwarded headers on a trusted host. How's that for irony? :)
+(test-response "Trusted proxies are stripped when determining IP address"
+ (200 "10.0.0.2")
+ "/whats-my-ip" "ip-host"
+ send-headers: `((x-forwarded-for "10.0.0.2" "10.0.0.1")))
+(test-response "Last proxy is used if all nodes are trusted"
+ (200 "10.0.0.1")
+ "/whats-my-ip" "ip-host"
+ send-headers: `((x-forwarded-for "10.0.0.1")))
+(test-end "miscellaneous")
+
+(test-begin "Caching and other efficiency support")
+(test-begin "If-Modified-Since/If-None-Match support")
+(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing\n")))
+(define timestamp (seconds->utc-time (current-seconds)))
+(test-response "If-Modified-Since when not modified"
+ (304 "") ; Should return 304 status, but also empty body
+ "/testfile.txt" "testhost"
+ send-headers: `((host ("testhost" . ,(server-port)))
+ (if-modified-since #(,timestamp ()))))
+(define original-etag
+ (header-value
+ 'etag
+ (fetch-file "/testfile.txt" "testhost"
+ get-headers: #t
+ send-headers: `((host ("testhost" . ,(server-port)))))))
+(test-response "If-None-Match when not modified"
+ (304 "") ; Should return 304 status, but also empty body
+ "/testfile.txt" "testhost"
+ send-headers: `((host ("testhost" . ,(server-port)))
+ (if-none-match ,original-etag)))
+(sleep 1)
+(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing2\n")))
+(test-response "If-Modified-Since when modified" (200 "Testing2\n")
+ "/testfile.txt" "testhost"
+ send-headers: `((host ("testhost" . ,(server-port)))
+ (if-modified-since #(,timestamp ()))))
+(test-response "If-None-Match when modified" (200 "Testing2\n")
+ "/testfile.txt" "testhost"
+ send-headers: `((host ("testhost" . ,(server-port)))
+ (if-none-match ,original-etag)))
+(let ((h (fetch-file "/testfile.txt" "testhost"
+ get-headers: #t
+ send-headers: `((host ("testhost" . ,(server-port)))
+ (if-modified-since #(,timestamp ()))))))
+ ;; RFC 2616, 10.3.5: Not modified must have date, unless clockless origin
+ ;; We don't explicitly check against a date because the second might
+ ;; roll over while we're doing the request or other nonsense.
+ (test "Headers contain Date"
+ #t
+ (not (not (header-value 'date h))))
+ ;; RFC 2616, 14.29:
+ ;; "HTTP/1.1 servers SHOULD send Last-Modified whenever feasible"
+ (test "Headers contain Last-Modified"
+ (file-modification-time "testweb/testfile.txt")
+ (utc-time->seconds (header-value 'last-modified h))))
+(delete-file "testweb/testfile.txt") ;; Clean up after the tests
+(test-end)
+(test-begin "HEAD support")
+(test-response "Regular response has no body" (200 #!eof)
+ "/hello.txt" "testhost" method: 'HEAD)
+(test-response "Status code responses have no body" (303 #!eof)
+ "/blah" "redirect-host" method: 'HEAD)
+(test-end)
+(test-end)
+
+(test-end)
+
+(test-exit)
diff --git a/tests/testlib.scm b/tests/testlib.scm
new file mode 100644
index 0000000..f706753
--- /dev/null
+++ b/tests/testlib.scm
@@ -0,0 +1,108 @@
+(import (chicken condition) (chicken format) (chicken io)
+ (chicken process-context) (chicken process-context posix)
+ (chicken tcp) (chicken process) (chicken file posix)
+ uri-common intarweb srfi-18)
+
+(server-port (string->number
+ (or (get-environment-variable "SPIFFY_TEST_PORT") "8080")))
+
+(define (check-port)
+ (let ((listener #f)
+ (msg (sprintf "Checking port ~A is available" (server-port))))
+ (handle-exceptions exn (void)
+ (set! listener (tcp-listen (server-port))))
+ (test-assert msg (tcp-listener? listener))
+ (tcp-close listener)))
+
+(define spiffy-pid #f)
+
+(define (can-connect?)
+ (handle-exceptions exn #f
+ (receive (in out)
+ (tcp-connect "127.0.0.1" (server-port))
+ (close-input-port in)
+ (close-output-port out)
+ #t)))
+
+(define (wait-for-spiffy times)
+ (if (zero? times)
+ #f
+ (begin (thread-sleep! 1) (or (can-connect?) (wait-for-spiffy (sub1 times))))))
+
+(define NOT-FOUND "file not found")
+
+(define (send-string/code code reason string)
+ (current-response
+ (update-response (current-response)
+ code: code reason: reason))
+ (write-logged-response)
+ (display string (response-port (current-response))))
+
+(define response-error? #f)
+
+(define (start-spiffy)
+ (check-port)
+ (set! spiffy-pid
+ (process-fork
+ (lambda ()
+ (parameterize ((root-path "./testweb")
+ (error-log (get-environment-variable "SPIFFY_ERROR_LOG"))
+ (handle-not-found
+ (lambda (p)
+ (send-string/code 404 "Not found" NOT-FOUND)))
+ (handle-exception
+ (lambda (exn chain)
+ (let ((m ((condition-property-accessor 'exn 'message) exn))
+ (a ((condition-property-accessor 'exn 'arguments) exn)))
+ (log-to (error-log) (build-error-message exn chain #t))
+ (set! response-error? #t)
+ (send-string/code 500 "Internal server error"
+ (if (and a (not (null? a)))
+ (sprintf "~A ~A" m a)
+ m))))))
+ (start-server)))))
+ (on-exit (lambda _ (process-signal spiffy-pid)))
+ (test-assert "Spiffy responds in 3 seconds" (wait-for-spiffy 3))
+ (void))
+
+;;;; test tools
+
+(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t))
+ (set! response-error? #f)
+ (let ((uri (uri-reference (if absolute-uri
+ (sprintf "http://~A:~A~A" host (server-port) file)
+ file))))
+ (receive (in out)
+ (tcp-connect "127.0.0.1" (server-port))
+ (let* ((req-headers (headers send-headers))
+ (req (make-request method: method uri: uri
+ major: (car version) minor: (cadr version)
+ headers: req-headers port: out)))
+ (write-request req)
+ (let* ((resp (read-response in))
+ (str (read-string (header-value 'content-length (response-headers resp)) in)))
+ (close-output-port out)
+ (close-input-port in)
+ (if get-headers
+ (response-headers resp)
+ (list (response-code resp) str)))))))
+
+(define-syntax test-response
+ (syntax-rules ()
+ ((_ ?text (?code-expected ?contents-expected) ?args ...)
+ (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ...)))
+ ((_ ?text ?code-expected ?args ...)
+ (test ?text ?code-expected (car (fetch-file ?args ...))))))
+
+(define-syntax test-header
+ (syntax-rules ()
+ ((_ ?text ?header-name (?header-values ...) ?args ...)
+ (test ?text `(?header-values ...)
+ (header-values `?header-name
+ (fetch-file ?args ... get-headers: #t))))))
+
+;; Create an uri for this test server, which is needed because its
+;; port may be overridden.
+(define (testserver-uri str)
+ (let ((ref (uri-reference str)))
+ (update-uri ref port: (server-port))))
diff --git a/tests/testweb/data b/tests/testweb/data
new file mode 100644
index 0000000..1331fda
--- /dev/null
+++ b/tests/testweb/data
@@ -0,0 +1 @@
+This is some data. Who knows what content type it could be? \ No newline at end of file
diff --git a/tests/testweb/denied.txt b/tests/testweb/denied.txt
new file mode 100644
index 0000000..94e2755
--- /dev/null
+++ b/tests/testweb/denied.txt
@@ -0,0 +1 @@
+This file should not be accessible (tests ensure that)
diff --git a/tests/testweb/hello.txt b/tests/testweb/hello.txt
new file mode 100644
index 0000000..270c611
--- /dev/null
+++ b/tests/testweb/hello.txt
@@ -0,0 +1 @@
+hello, world!
diff --git a/tests/testweb/index.html b/tests/testweb/index.html
new file mode 100644
index 0000000..4ec1376
--- /dev/null
+++ b/tests/testweb/index.html
@@ -0,0 +1,15 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <title>This is an index page</title>
+</head>
+<body>
+<h1>An index page</h1>
+
+<p>Hard to believe, but yes, this is an index page. It does not really
+provide you with an index of any kind, but it's here to let spiffy's
+test know that we loaded the index page even when we simply provided a
+directory name with no filename.</p>
+</body>
+</html> \ No newline at end of file
diff --git a/tests/testweb/once.scm b/tests/testweb/once.scm
new file mode 100644
index 0000000..f725903
--- /dev/null
+++ b/tests/testweb/once.scm
@@ -0,0 +1,2 @@
+(let ((counter (with-input-from-file "counter" read)))
+ (with-output-to-file "counter" (lambda () (write (add1 counter)))))
diff --git a/tests/testweb/pics/chicken-logo.png b/tests/testweb/pics/chicken-logo.png
new file mode 100644
index 0000000..072b068
--- /dev/null
+++ b/tests/testweb/pics/chicken-logo.png
Binary files differ
diff --git a/tests/testweb/pics/lambda-chicken.gif b/tests/testweb/pics/lambda-chicken.gif
new file mode 100644
index 0000000..5c3ccc7
--- /dev/null
+++ b/tests/testweb/pics/lambda-chicken.gif
Binary files differ
diff --git a/tests/testweb/secrets/bank/pin-code.txt b/tests/testweb/secrets/bank/pin-code.txt
new file mode 100644
index 0000000..81c545e
--- /dev/null
+++ b/tests/testweb/secrets/bank/pin-code.txt
@@ -0,0 +1 @@
+1234
diff --git a/tests/testweb/secrets/password.txt b/tests/testweb/secrets/password.txt
new file mode 100644
index 0000000..a1ddf5c
--- /dev/null
+++ b/tests/testweb/secrets/password.txt
@@ -0,0 +1 @@
+Follow the yellow brick road \ No newline at end of file
diff --git a/tests/testweb/secrets/spiffy-access b/tests/testweb/secrets/spiffy-access
new file mode 100644
index 0000000..bd6e4e8
--- /dev/null
+++ b/tests/testweb/secrets/spiffy-access
@@ -0,0 +1,5 @@
+(lambda (continue)
+ (with-headers `((content-length ,(string-length noway)))
+ (lambda ()
+ (write-logged-response)
+ (display noway (response-port (current-response)))))) \ No newline at end of file
diff --git a/tests/testweb/spiffy-access b/tests/testweb/spiffy-access
new file mode 100644
index 0000000..a4ffff5
--- /dev/null
+++ b/tests/testweb/spiffy-access
@@ -0,0 +1,4 @@
+(lambda (continue)
+ (let ((counter (with-input-from-file "root-counter" read)))
+ (with-output-to-file "root-counter" (lambda () (write (add1 counter)))))
+ (continue))
diff --git a/tests/testweb/subdir with space/index.html b/tests/testweb/subdir with space/index.html
new file mode 100644
index 0000000..0d97655
--- /dev/null
+++ b/tests/testweb/subdir with space/index.html
@@ -0,0 +1,14 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <title>This is an index page in a subdir with a space</title>
+</head>
+<body>
+<h1>An index page</h1>
+
+<p>This is here to test whether Spiffy can handle redirects to URLs
+with spaces (and more generally, encoding of special URI chars)
+correctly.</p>
+</body>
+</html>
diff --git a/tests/testweb/subdir/index.html b/tests/testweb/subdir/index.html
new file mode 100644
index 0000000..8fecc46
--- /dev/null
+++ b/tests/testweb/subdir/index.html
@@ -0,0 +1,15 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <title>This is an index page in a subdir</title>
+</head>
+<body>
+<h1>An index page</h1>
+
+<p>Hard to believe, but yes, this is an index page in a subdir.
+It does not really provide you with an index of any kind, but it's
+here to let spiffy's test know that we loaded the index page even
+when we simply provided a directory name with no filename.</p>
+</body>
+</html>
diff --git a/tests/testweb/subdir/spiffy-access b/tests/testweb/subdir/spiffy-access
new file mode 100644
index 0000000..265eb7b
--- /dev/null
+++ b/tests/testweb/subdir/spiffy-access
@@ -0,0 +1,4 @@
+(lambda (continue)
+ (let ((counter (with-input-from-file "counter" read)))
+ (with-output-to-file "counter" (lambda () (write (add1 counter)))))
+ (continue))
diff --git a/tests/testweb/subdir/subsubdir/index.html b/tests/testweb/subdir/subsubdir/index.html
new file mode 100644
index 0000000..de9d3c3
--- /dev/null
+++ b/tests/testweb/subdir/subsubdir/index.html
@@ -0,0 +1,15 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <title>This is an index page in a subdir under a subdir</title>
+</head>
+<body>
+<h1>An index page</h1>
+
+<p>Hard to believe, but yes, this is an index page in a subsubdir.
+It does not really provide you with an index of any kind, but it's
+here to let spiffy's test know that we loaded the index page even
+when we simply provided a directory name with no filename.</p>
+</body>
+</html>
diff --git a/tests/testweb/test.myscript b/tests/testweb/test.myscript
new file mode 100644
index 0000000..4b3bed3
--- /dev/null
+++ b/tests/testweb/test.myscript
@@ -0,0 +1 @@
+Contents of this file are irrelevant \ No newline at end of file