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 /simple-directory-handler.scm | |
download | spiffy-776d00c6cd7cabc16f13a18eee54fa2f3f36bf21.tar.gz |
Port to CHICKEN 5
Diffstat (limited to 'simple-directory-handler.scm')
-rw-r--r-- | simple-directory-handler.scm | 108 |
1 files changed, 108 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)))))))) +) |