1 files changed, 72 insertions, 0 deletions
diff --git a/file/file-browser.lisp b/file/file-browser.lisp
new file mode 100644
index 0000000..4694374
--- /dev/null
+++ b/file/file-browser.lisp
@@ -0,0 +1,72 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass file-browser ()
+  ((document-root :initarg :document-root
+                  :initform nil
+                  :accessor document-root
+                  :documentation "The highest level directory that the
+user is allowed to navigate to. Ends in a slash.")
+   (relative-path :initarg :relative-path
+                  :initform nil
+                  :accessor relative-path
+                  :documentation "Add this to `document-root'
+to get to the current directory, whose contents are to be
+displayed.")
+   (mime-extensions :initarg :mime-extensions
+                    :initform nil
+                    :accessor mime-extensions
+                    :documentation "A list of MIME file extensions
+that, if not `nil', will limit directory listings to show only those
+files that contain these extensions.")
+   (nodes :initarg :nodes
+          :initform ()
+          :accessor nodes
+          :documentation "The nodes of the current directory. A list
+of dotted pairs in the form '(([:directory|:file|:symlink] . <node-name>))."))
+   (:documentation "Used for directory-browsing. Keeps track of
+directory-navigating state in the `user-session'."))
+
+(defmethod absolute-path ((file-browser file-browser))
+  (ppcre:regex-replace-all "//"
+                           (format nil "~a/~a" (or (document-root file-browser) "") (or (relative-path file-browser) ""))
+                           "/"))
+
+(defmethod update-relative-path ((file-browser file-browser) node)
+  (when (not (null-or-empty-p node))
+    (if (equal node "..")
+        (if (null-or-empty-p (relative-path file-browser))
+            (setf (relative-path file-browser) "")
+            (setf (relative-path file-browser) (let ((path-list (nreverse (remove-if 'null-or-empty-p (ppcre:split "/" (relative-path file-browser)))))
+                                                     (new-path ""))
+                                                 (pop path-list)
+                                                 (loop for path-part in (nreverse path-list) do
+                                                      (setf new-path (format nil "~a~a/" new-path path-part)))
+                                                 (ppcre:regex-replace-all "/$" new-path ""))))
+        (if (null-or-empty-p (relative-path file-browser))
+            (setf (relative-path file-browser) node)
+            (setf (relative-path file-browser) (format nil "~a/~a" (relative-path file-browser) node))))))
+
+(defmethod directory-list ((file-browser file-browser))
+  (labels ((finder (type)
+             (remove-if 'null (mapcar (lambda (line)
+                                        (when (not (or (equal line ".")))
+                                          (let ((item (ppcre:regex-replace-all "\\./" line "")))
+                                            (when (or (null (mime-extensions file-browser))
+                                                      (equal type "d")
+                                                      (remove-if-not (lambda (x)
+                                                                       (match-it (format nil "~a$" x) item))
+                                                                     (mime-extensions file-browser)))
+                                              (cons (cond ((equal type "d") :directory)
+                                                          ((equal type "f") :file)
+                                                          ((equal type "l") :symlink))
+                                                    item)))))
+                                      (shell-wrapper (format nil
+                                                             "pushd '~a' >/dev/null ; find -maxdepth 1 -type ~a | sort ; popd >/dev/null"
+                                                             (absolute-path file-browser)
+                                                             type))))))
+    (setf (nodes file-browser) (remove-if 'null (append `((:directory . "..")) (finder "d") (finder "f") (finder "l"))))))