diff options
| author | Peter Bex <peter@more-magic.net> | 2018-07-29 19:39:39 +0200 |
|---|---|---|
| committer | Peter Bex <peter@more-magic.net> | 2018-07-29 19:39:39 +0200 |
| commit | 776d00c6cd7cabc16f13a18eee54fa2f3f36bf21 (patch) | |
| tree | e965a2808a234d83c8a31ef0965f73784db1bac8 | |
| download | spiffy-776d00c6cd7cabc16f13a18eee54fa2f3f36bf21.tar.gz | |
Port to CHICKEN 5
| -rw-r--r-- | simple-directory-handler.scm | 108 | ||||
| -rw-r--r-- | spiffy.egg | 12 | ||||
| -rw-r--r-- | spiffy.scm | 667 | ||||
| -rw-r--r-- | tests/run.scm | 287 | ||||
| -rw-r--r-- | tests/testlib.scm | 108 | ||||
| -rw-r--r-- | tests/testweb/data | 1 | ||||
| -rw-r--r-- | tests/testweb/denied.txt | 1 | ||||
| -rw-r--r-- | tests/testweb/hello.txt | 1 | ||||
| -rw-r--r-- | tests/testweb/index.html | 15 | ||||
| -rw-r--r-- | tests/testweb/once.scm | 2 | ||||
| -rw-r--r-- | tests/testweb/pics/chicken-logo.png | bin | 0 -> 24679 bytes | |||
| -rw-r--r-- | tests/testweb/pics/lambda-chicken.gif | bin | 0 -> 1050 bytes | |||
| -rw-r--r-- | tests/testweb/secrets/bank/pin-code.txt | 1 | ||||
| -rw-r--r-- | tests/testweb/secrets/password.txt | 1 | ||||
| -rw-r--r-- | tests/testweb/secrets/spiffy-access | 5 | ||||
| -rw-r--r-- | tests/testweb/spiffy-access | 4 | ||||
| -rw-r--r-- | tests/testweb/subdir with space/index.html | 14 | ||||
| -rw-r--r-- | tests/testweb/subdir/index.html | 15 | ||||
| -rw-r--r-- | tests/testweb/subdir/spiffy-access | 4 | ||||
| -rw-r--r-- | tests/testweb/subdir/subsubdir/index.html | 15 | ||||
| -rw-r--r-- | tests/testweb/test.myscript | 1 |
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 '(("<" . "<") (">" . ">") + ("\"" . """) ("'" . "'") ("&" . "&")))) + +;; 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 Binary files differnew file mode 100644 index 0000000..072b068 --- /dev/null +++ b/tests/testweb/pics/chicken-logo.png diff --git a/tests/testweb/pics/lambda-chicken.gif b/tests/testweb/pics/lambda-chicken.gif Binary files differnew file mode 100644 index 0000000..5c3ccc7 --- /dev/null +++ b/tests/testweb/pics/lambda-chicken.gif 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 |
