add storage package, copied from other proj. so already implemented.

ritherdon-archive.asd

@@ -55,6 +55,7 @@
 	       (:file "models/site-settings")
 	       (:file "auth")
 	       (:file "nera") ; (Name of Database)
+	       (:file "storage")
 	       ;; Caveman Files
 	       (:file "web"))
 	       

src/storage.lisp

@@ -0,0 +1,178 @@
+(in-package #:cl-user)
+(defpackage #:storage
+  (:use #:cl)
+  (:export #:directory-exists-p
+	   #:ensure-directory-exists
+	   #:file-exists-p
+	   #:get-files-in-directory
+	   #:get-file-names
+	   #:get-latest-file-type
+	   #:make-path
+	   #:open-file
+	   #:open-binary-file
+	   #:open-text-file
+	   #:remove-directory
+	   #:remove-file
+	   #:rename-content-file
+	   #:rename-directory
+	   #:store-file
+	   #:store-text))
+(in-package #:storage)
+
+(defun directory-exists-p (username directory)
+  "Checks to see if the specified diretory exists.
+The directories path is returned if it does exist and `NIL' is
+returned if the directory cannot be found."
+  (cl:probe-file (make-path username directory "")))
+
+(defun ensure-directory-exists (username directory)
+  "The project's standardised way to call `ENSURE-DIRECTORY-EXISTS'.
+If the directory exists, the full (absolute) path is
+returned (equating to `T', otherwiser `NIL' it returned."
+  ;; The empty string for `SLUG' (3rd arg.) is used because
+  ;; `MAKE-PATH' can form paths for files. In this instance, only the
+  ;; directory needs to be formed. The empty string kinda acts like
+  ;; `NIL' but it is a bit of a hack, I will admit.
+  (ensure-directories-exist (make-path username directory "")))
+
+(defun file-exists-p (username subdirectory slug)
+  "This project's standardised way to call `CL:PROBE-FILE'.
+If the file exists, the full (absolute) path is returned (equates to
+`T', otherwise `NIL' is returned."
+  (cl:probe-file (make-path username subdirectory slug)))
+
+(defun get-files-in-directory (username directory)
+  ""
+  (uiop:directory-files (make-path username directory "")))
+
+(defun get-file-names (filenames)
+  ""
+  (mapcar #'(lambda (x) (file-namestring x)) filenames))
+
+(defun get-latest-file-type (old-file new-file)
+  "NOT IMPLEMENTED! Gets the file type of the specified `FILE', return `NIL' if no file found"
+  ;; (if (string= "" (cadr new-file))
+  ;;     (file::content-type-of old-file)
+  ;;     (caddr new-file)))
+  (format t "[WARNING] get-latest-file-type not implemented."))
+
+(defun make-path (username subdirectory slug)
+  "Forms the path used to save a file.
+Storage path:
+`*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/`SLUG'
+Each user has their own directory in /storage. This is so I can build a media
+manager at a later date -- I had not got around to writing it at the time I
+implemented this function/feature. I decided to go with `USERNAME' and
+not (user-)`ID' is because I wanted to easily identify the directories in
+/storage."
+  (merge-pathnames (format nil "storage/~A/~A/~A"
+			   username subdirectory slug)
+		   ritherdon-archive.config::*application-root*))
+
+(defun open-binary-file (username subdirectory slug)
+  "Reads the file stored in the /storage directory."
+  (with-open-file (stream
+		   (make-path username subdirectory slug)
+		   :element-type '(unsigned-byte 8))
+    (let* ((length (file-length stream))
+	   (buffer (make-array length
+			       :element-type '(unsigned-byte 8))))
+      (read-sequence buffer stream)
+      (values buffer length))))
+
+(defun open-text-file (username subdirectory slug)
+  "Reads the text (.md) file stored in the /storage directory."
+  (with-open-file (stream (make-path username subdirectory slug))
+    (let ((data (make-string (file-length stream))))
+      (read-sequence data stream)
+      data)))
+
+(defun remove-directory (username subdirectory)
+  "Deletes an entire sketchbook directory in /storage (not database).
+Path template: `*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/'
+- https://edicl.github.io/cl-fad/#delete-directory-and-files
+- https://stackoverflow.com/questions/24350183/how-do-i-delete-a-directory-in-common-lisp
+'cl-fad' (files and directories) is a wrapper package over the various
+Common Lisp implementions to aid in keeping your Common Lisp code
+portable. At the time of writing (February 2022), the website is using
+Steel Bank Common Lisp (SBCL) but this allow you to use something else
+if you want or need to switch."
+  (cl-fad:delete-directory-and-files (make-path username subdirectory "")))
+
+(defun rename-directory (username original-directory new-directory)
+  "Renames a sub-directory in the /storage directory.
+`USERNAME' is the directory holding the one which is to be
+changed. `ORIGINAL-DIRECTORY' is the 'source' (in the usual Linux/Bash
+CLI sense). `NEW-DIRECTORY' is the name the `ORIGINAL-DIRECTORY' will
+be changed to. There are various examples of the path
+structure/template in other comments in this file. Have a look
+around (don't want to repeat myself)."
+  (rename-file (make-path username original-directory "")
+	       (make-path username new-directory "")))
+
+(defun remove-file (username subdirectory slug)
+  "Deletes the specified file, stored in the /storage directory.
+Before calling this function, make sure the file exists. You should have
+'file-exists-p' available to you -- within this (storage) package."
+  (delete-file (make-path username subdirectory slug)))
+
+(defun rename-content-file (username subdirectory old-slug new-slug)
+  "This project's standardised way to call `RENAME-FILE'."
+  (rename-file (make-path username subdirectory old-slug)
+	       (make-path username subdirectory new-slug)))
+
+(defun store-file (username subdirectory filename data)
+  "Stores the uploaded file to the /storage directory.
+Storage path: `*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/`FILENAME'
+`DATA' is the actual contents which will be written to the said path."
+  (let ((path (ensure-directories-exist
+	       (make-path username subdirectory filename))))
+    (cond ((or (string= (caddr data) "application/gzip")
+	       (string= (caddr data) "application/zip")
+	       (string= (caddr data) "application/epub+zip"))
+	   (uiop:copy-file (slot-value (car data) 'pathname) path))
+	  (t
+	   (with-open-file (stream
+			    path
+			    :direction :output
+			    :if-does-not-exist :create
+			    :element-type '(unsigned-byte 8)
+			    :if-exists :supersede)
+	     (write-sequence (slot-value (car data) 'vector) stream))))))
+
+(defun store-text (username subdirectory filename data)
+  "Stores the plain text to the /storage directory.
+Storage path: `*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/`FILENAME'
+`DATA' is the actual text/data which will be written to the said path."
+  (let ((path (ensure-directories-exist
+	       (make-path username subdirectory filename))))
+	   (with-open-file (stream
+			    path
+			    :direction :output
+			    :if-does-not-exist :create
+			    :if-exists :supersede)
+	     (format stream "~a~%" data))))
+
+;;; PORTED FROM RAILS-TO-CAVEMAN PROJECT (expect it to be deleted)
+;;; =============================================================================
+
+(defun prin1-to-base64-string (object)
+  (cl-base64:string-to-base64-string (prin1-to-string object)))
+
+(defun read-from-base64-string(string)
+  (values (read-from-string
+	   (cl-base64:base64-string-to-string string))))
+
+;;; This function requires ImageMagick so you will need to install it
+;;; with 'sudo apt install imagemagick' (assuming you are on a
+;;; Debian-based system).
+(defun convert (id subdirectory original-file converted-file)
+  (let ((command (format nil "convert -geometry ~A ~A ~A"
+			 (file-size converted-file)
+			 (make-storage-pathname id subdirectory original-file)
+			 (make-storage-pathname id subdirectory converted-file))))
+    (let ((message (nth-value 1
+			      (uiop:run-program command
+						:ignore-error-status t
+						:error-output :string))))
+      (when message (error message)))))