summaryrefslogtreecommitdiff
path: root/simple-directory-handler.scm
blob: c232478b1f795b44e493ea4cea1b953f5b087835 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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))))))))
)