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
109
110
111
112
113
114
115
116
117
|
;;;; simple-directory-handler.scm
;
; Copyright (c) 2007-2009, 2012, 2018-2019, 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 (only uri-common uri-encode-string char-set:uri-unreserved)
(only srfi-14 char-set-complement char-set-delete))
(cond-expand
(chicken-6 (import (scheme base))) ; For make-parameter, which moved from (chicken base)
(else))
(define (encode-path p)
(let ((cs (char-set-delete (char-set-complement char-set:uri-unreserved) #\/)))
(uri-encode-string p cs)))
(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 (encode-path 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))))))))
)
|
