[hunchentoot-devel] folder-dispatcher directory listing
Mac Chan
emailmac at gmail.com
Fri Feb 16 02:35:10 UTC 2007
Hi all,
Lately I've been doing some plain html and javascript hacking on
*.html and *.js file, and I found the apache directory listing to be
quite handy (IE won't let you run scripts from file:/// so you must
host it in a server and access with http://localhost/).
I'm using mod_lisp w/ apache so this is not a problem for me but I
intend to use hunchentoot alone when it stabilized.
I've seen people asking for this before so here's a simple patch to
enable directory listing for create-folder-dispatcher-and-handler.
Originally I want to change the signature from
create-folder-dispatcher-and-handler (uri-prefix base-path &optional
content-type)
to
create-folder-dispatcher-and-handler (uri-prefix base-path &optional
create-index-page-p content-type)
but it makes it inconsistent with the other api. (and that I don't
need to update the documentation :-)
Anyway attached are the diffs so feel free to change it if you really
don't want the index page enabled by default.
Cheers,
-- Mac
(PS The code should look less horrible if cl-who is available but it's
really a pain since I don't want to introduce dependencies to
hunchentoot. There is one function copied directly from cl-fad for the
same reason)
-------------- next part --------------
==== hunchentoot/misc.lisp#1 - hunchentoot/misc.lisp ====
***************
*** 137,144 ****
denoted by PATH. Send a content type header corresponding to
CONTENT-TYPE or \(if that is NIL) tries to determine the content
type via the file's suffix."
! (unless (or (pathname-name path)
! (pathname-type path))
;; not a file
(setf (return-code) +http-bad-request+)
(throw 'handler-done nil))
--- 137,145 ----
denoted by PATH. Send a content type header corresponding to
CONTENT-TYPE or \(if that is NIL) tries to determine the content
type via the file's suffix."
! (unless (and path
! (or (pathname-name path)
! (pathname-type path)))
;; not a file
(setf (return-code) +http-bad-request+)
(throw 'handler-done nil))
***************
*** 177,182 ****
--- 178,315 ----
(lambda ()
(handle-static-file path content-type)))))
+ ;; should pull in cl-fad for one function?
+ (defun directory-pathname-p (pathspec)
+ "Returns NIL if PATHSPEC \(a pathname designator) does not designate
+ a directory, PATHSPEC otherwise. It is irrelevant whether file or
+ directory designated by PATHSPEC does actually exist."
+ (flet ((component-present-p (value)
+ (and value (not (eql value :unspecific)))))
+ (and
+ (not (component-present-p (pathname-name pathspec)))
+ (not (component-present-p (pathname-type pathspec)))
+ pathspec)))
+
+ (defun file-size (file)
+ "Returns filesize in bytes, or NIL if it is a directory."
+ (cl:ignore-errors
+ (with-open-file (in file :direction :input)
+ (file-length in))))
+
+ (defstruct file-details name date size (desc "" :type string))
+
+ (defun file-date-string (file-details)
+ "Returns a descriptive string like \"15-Feb-2007\"."
+ (multiple-value-bind
+ (second minute hour date month year)
+ (decode-universal-time (file-details-date file-details))
+ (declare (ignore second minute hour))
+ (let ((month-names
+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
+ (format nil "~2,'0d-~A-~D"
+ date (nth (1- month) month-names) year))))
+
+ (defun file-size-string (file-details)
+ "Returns a descriptive string like \"1.3K\" or \"8M\"."
+ (let ((size (file-details-size file-details)))
+ (cond ((not (numberp size)) "- ")
+ ((< size 1024) (format nil "~D " size))
+ ((< size (* 1024 1024)) (format nil "~,1FK" (/ size 1024)))
+ (t (format nil "~,1FM" (/ size (* 1024 1024)))))))
+
+ (defun maybe-integer-lessp (a b)
+ "If both a & b are numbers, then it's just like #'<
+ Otherwise, non number goes first."
+ (cond ((and (numberp a) (numberp b))
+ (< a b))
+ ((numberp b) t)
+ (t nil)))
+
+ (defun sort-file-details (list &optional (sort-column "N") (sort-order "A"))
+ "Sort file-details based on sort column and order."
+ (let* ((sort-column (intern sort-column :keyword))
+ (compare-func
+ (ecase sort-column
+ ((:M :S) #'maybe-integer-lessp)
+ ((:N :D) #'string-lessp)))
+ (selector
+ (ecase sort-column
+ (:N #'file-details-name)
+ (:M #'file-details-date)
+ (:S #'file-details-size)
+ (:D #'file-details-desc)))
+ (results (sort list compare-func :key selector)))
+ (if (string-equal sort-order "D")
+ (nreverse results)
+ results)))
+
+ (defun redirect-if-malformed-pathspec ()
+ "Directory listing request should end in a forward slash like
+ \"http://localhost/hunchentoot/code/\". Fix it if it is not the
+ case."
+ (let* ((script-name (script-name))
+ (length (length script-name)))
+ (unless (and (> length 0)
+ (char= (aref script-name (1- length)) #\/))
+ ;; stripping the query string is OK
+ (redirect (concatenate 'string script-name "/")))))
+
+ (defun folder-index-page (pathname)
+ "Returns a html page with a directory listing like those generated
+ by Apache."
+ (redirect-if-malformed-pathspec)
+ (let* ((contents (directory (namestring pathname)))
+ (title (format nil "Index of ~A" (script-name)))
+ (sort-column (get-parameter "C"))
+ (sort-order (get-parameter "O")))
+ (flet ((file-details (file)
+ (make-file-details :name (enough-namestring file pathname)
+ :date (file-write-date file)
+ :size (file-size file))))
+ ;; taint get-parameters
+ (unless (member sort-column '("N" "M" "S" "D") :test #'string-equal)
+ (setq sort-column "N"))
+ (unless (member sort-order '("A" "D") :test #'string-equal)
+ (setq sort-order "A"))
+ ;; page-out
+ (with-output-to-string (out)
+ (format out "<html><head><title>~A</title>
+ <style type=\"text/css\">
+ <!--
+ .size { text-align: right; }
+ th { padding: 0.2em; text-align: left; }
+ td { padding: 0.2em; }
+ table { font-family: monospace; }
+ -->
+ </style></head><body><h1>~A</h1><table><tr>" title title)
+ ;; column headers
+ (loop for (query-char desc) in
+ '(("N" "Name")
+ ("M" "Last modified")
+ ("S" "Size")
+ ("D" "Description")) do
+ (format out "<th><a href=\"?C=~A&O=~A\">~A</a></th>"
+ query-char
+ (or (when (string-equal query-char sort-column)
+ (if (string-equal sort-order "D") "A" "D"))
+ "A")
+ desc))
+ (format out "</tr><tr><td colspan=\"4\"><hr/></td></tr><tr>
+ <td><a href=\"../\">Parent Directory</a></td>
+ <td></td><td></td><td></td></tr>")
+ (dolist (d (sort-file-details
+ (mapcar #'file-details contents)
+ sort-column sort-order))
+ (format out "<tr><td><a href=\"~A\">~A</a></td>"
+ (file-details-name d) (file-details-name d))
+ (format out "<td>~A</td><td class=\"size\">~A</td><td>~A</td></tr>"
+ (file-date-string d)
+ (file-size-string d)
+ (file-details-desc d)))
+ (format out "<tr><td colspan=\"4\"><hr/></td></tr></table>
+ <p>~A</p></body></html>" (address-string))))))
+
(defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type)
"Creates and returns a dispatch function which will dispatch to a
handler function which emits the file relative to BASE-PATH that is
***************
*** 203,209 ****
always (stringp component))))
(setf (return-code) +http-forbidden+)
(throw 'handler-done nil))
! (handle-static-file (merge-pathnames script-path base-path) content-type))))
(create-prefix-dispatcher uri-prefix #'handler)))
(defun no-cache ()
--- 336,345 ----
always (stringp component))))
(setf (return-code) +http-forbidden+)
(throw 'handler-done nil))
! (let ((pathname (probe-file (merge-pathnames script-path base-path))))
! (if (and pathname (directory-pathname-p pathname))
! (folder-index-page pathname)
! (handle-static-file pathname content-type))))))
(create-prefix-dispatcher uri-prefix #'handler)))
(defun no-cache ()
==== hunchentoot/test/test.lisp#1 - hunchentoot/test/test.lisp ====
***************
*** 501,506 ****
--- 501,508 ----
" (user 'nanook', password 'igloo')"))
(:tr (:td (:a :href "/hunchentoot/code/test.lisp"
"The source code of this test")))
+ (:tr (:td (:a :href "/hunchentoot/code/"
+ "Listing of the code directory")))
(:tr (:td (:a :href "/hunchentoot/test/image.jpg"
"Binary data, delivered from file")
" \(a picture)"))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: misc.lisp
Type: application/octet-stream
Size: 18253 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/tbnl-devel/attachments/20070215/2dfe970c/attachment.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: test.lisp
Type: application/octet-stream
Size: 24018 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/tbnl-devel/attachments/20070215/2dfe970c/attachment-0001.obj>
More information about the Tbnl-devel
mailing list