summaryrefslogtreecommitdiff
path: root/simple-directory-handler.scm
diff options
context:
space:
mode:
Diffstat (limited to 'simple-directory-handler.scm')
-rw-r--r--simple-directory-handler.scm108
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))))))))
+)