==== 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 "~A +

~A

" title title) + ;; column headers + (loop for (query-char desc) in + '(("N" "Name") + ("M" "Last modified") + ("S" "Size") + ("D" "Description")) do + (format out "" + query-char + (or (when (string-equal query-char sort-column) + (if (string-equal sort-order "D") "A" "D")) + "A") + desc)) + (format out " + + ") + (dolist (d (sort-file-details + (mapcar #'file-details contents) + sort-column sort-order)) + (format out "" + (file-details-name d) (file-details-name d)) + (format out "" + (file-date-string d) + (file-size-string d) + (file-details-desc d))) + (format out "
~A
Parent Directory
~A~A~A~A
+

~A

" (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)"))