source: project/release/4/spiffy/trunk/simple-directory-handler.scm @ 13082

Last change on this file since 13082 was 12527, checked in by sjamaan, 12 years ago

Add logging support

File size: 3.7 KB
Line 
1;;;; simple-directory-handler.scm
2;
3; Copyright (c) 2007-2008, Peter Bex
4; Copyright (c) 2000-2005, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of the author nor the names of its
17;    contributors may be used to endorse or promote products derived
18;    from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32
33(module simple-directory-handler
34  (simple-directory-handler simple-directory-dotfiles?
35                            simple-directory-display-file)
36
37(import chicken scheme srfi-1 extras spiffy files posix data-structures ports)
38(require-extension intarweb)
39
40(define simple-directory-dotfiles? (make-parameter #f))
41(define simple-directory-display-file
42  (make-parameter
43   (lambda (remote-file local-file dir?)
44     (sprintf "<tr>
45                 <td><a href=\"~a\">~a</a></td>
46                 <td>~a</td>
47                 <td>~a</td>
48               </tr>\n"
49             remote-file
50             (htmlize (pathname-strip-directory remote-file))
51             (file-size local-file)
52             (seconds->string (file-modification-time local-file))))))
53
54(define (simple-directory-handler path)
55  (let ([str
56         (sprintf
57          "<!DOCTYPE html PUBLIC
58           \"-//W3C//DTD XHTML 1.0 Strict//EN\"
59           \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
60<html lang=\"en\">
61  <head>
62    <title>Index of ~a</title>
63  </head>
64  <body>
65    <h2>Index of ~a:</h2>
66    <p><a href=\"~a\">Go to parent directory</a></p>
67    <table>~a</table>
68  </body>
69</html>"
70          path
71          path
72          (or (pathname-directory path) path)
73          (let ([dir (sort (directory (make-pathname (root-path) path)
74                                      (simple-directory-dotfiles?))
75                           string<?)])
76            (fold
77             (lambda (file str)
78               (let* ((local-file (make-pathname (list (root-path) path)
79                                                 file))
80                      (remote-file (make-pathname path file))
81                      (dir? (directory? local-file)))
82                 (if (file-exists? local-file)
83                     (string-append str ((simple-directory-display-file)
84                                         remote-file local-file dir?))
85                     str)))
86             ""
87             dir)))])
88    (with-headers `((content-type text/html)
89                    (content-length ,(string-length str)))
90      (lambda ()
91       (write-logged-response)
92       (display str (response-port (current-response)))))))
93)
Note: See TracBrowser for help on using the repository browser.