diff --git a/ritherdon-archive.asd b/ritherdon-archive.asd index 61c600c..7830062 100644 --- a/ritherdon-archive.asd +++ b/ritherdon-archive.asd @@ -55,6 +55,7 @@ (:file "models/site-settings") (:file "auth") (:file "nera") ; (Name of Database) + (:file "storage") ;; Caveman Files (:file "web")) diff --git a/src/storage.lisp b/src/storage.lisp new file mode 100644 index 0000000..ae17413 --- /dev/null +++ b/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)))))