diff options
| -rw-r--r-- | simple-directory-handler.scm | 53 |
1 files changed, 29 insertions, 24 deletions
diff --git a/simple-directory-handler.scm b/simple-directory-handler.scm index c232478..4d722c6 100644 --- a/simple-directory-handler.scm +++ b/simple-directory-handler.scm @@ -1,6 +1,6 @@ ;;;; simple-directory-handler.scm ; -; Copyright (c) 2007-2009, 2012, 2018, Peter Bex +; Copyright (c) 2007-2009, 2012, 2018-2019, Peter Bex ; Copyright (c) 2000-2005, Felix L. Winkelmann ; All rights reserved. ; @@ -37,7 +37,12 @@ (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) + intarweb spiffy (only uri-common uri-encode-string char-set:uri-unreserved) + (only srfi-14 char-set-complement char-set-delete)) + +(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 @@ -48,16 +53,16 @@ <td>~a</td> <td>~a</td> </tr>\n" - (htmlize remote-file) + (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 + (let ((str (sprintf - "<!DOCTYPE html PUBLIC + "<!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\"> @@ -79,26 +84,26 @@ </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) + 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)))]) + "" + dir))))) (with-headers `((content-type text/html) (content-length ,(string-length str))) (lambda () |