[hunchentoot-devel] folder-dispatcher directory listing
Mac Chan
emailmac at gmail.com
Fri Feb 16 03:28:31 UTC 2007
On 2/15/07, Pierre THIERRY <nowhere.man at levallois.eu.org> wrote:
> Why not make it a small separate package depending on cl-fad and cl-who,
> then?
>
> Alternatively,
> Pierre
I've seen Edi dump html directly in several places, so I guess it's a
ok trade-off.
Anyway, turns out that #'directory behaves quite differently in sbcl
(and other lisps), and the patch submitted earlier only works on
lispworks.
So after all I need to pull in cl-fad, I'm not sure if this is a bad thing...
-- Mac
-------------- next part --------------
A non-text attachment was scrubbed...
Name: hunchentoot.asd
Type: application/octet-stream
Size: 3068 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/tbnl-devel/attachments/20070215/e652d0f6/attachment.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: misc.lisp
Type: application/octet-stream
Size: 17760 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/tbnl-devel/attachments/20070215/e652d0f6/attachment-0001.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/e652d0f6/attachment-0002.obj>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/tbnl-devel/attachments/20070215/e652d0f6/attachment.html>
-------------- next part --------------
diff hunchentoot-0.6.1/hunchentoot.asd hunchentoot/hunchentoot.asd
47a48
> :cl-fad
diff hunchentoot-0.6.1/misc.lisp hunchentoot/misc.lisp
140,141c140,142
< (unless (or (pathname-name path)
< (pathname-type path))
---
> (unless (and path
> (or (pathname-name path)
> (pathname-type path)))
179a181,300
> (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 (cl-fad:list-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))))))
>
206c327,330
< (handle-static-file (merge-pathnames script-path base-path) content-type))))
---
> (let ((pathname (probe-file (merge-pathnames script-path base-path))))
> (if (and pathname (cl-fad:directory-pathname-p pathname))
> (folder-index-page pathname)
> (handle-static-file pathname content-type))))))
diff hunchentoot-0.6.1/test/test.lisp hunchentoot/test/test.lisp
503a504,505
> (:tr (:td (:a :href "/hunchentoot/code/"
> "Listing of the code directory")))
diff hunchentoot-0.6.1/doc/index.html hunchentoot/doc/index.html
128c128
< <li>and my own <a href='http://weitz.de/chunga/'>Chunga</a>, <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a>, and <a href='http://weitz.de/url-rewrite/'>URL-REWRITE</a> (plus <a href="http://weitz.de/cl-who/">CL-WHO</a> for the <a href="#example">example code</a>).
---
> <li>and my own <a href='http://weitz.de/chunga/'>Chunga</a>, <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a>, <a href='http://weitz.de/cl-fad/'>CL-FAD</a>, and <a href='http://weitz.de/url-rewrite/'>URL-REWRITE</a> (plus <a href="http://weitz.de/cl-who/">CL-WHO</a> for the <a href="#example">example code</a>).
More information about the Tbnl-devel
mailing list