|
|
|
(in-package #:cl-user)
|
|
|
|
(defpackage #:storage
|
|
|
|
(:use #:cl
|
|
|
|
#:copy-directory)
|
|
|
|
(:export #:init-storage
|
|
|
|
#:directory-exists-p
|
|
|
|
#:ensure-directory-exists
|
|
|
|
#:file-exists-p
|
|
|
|
#:get-files-in-directory
|
|
|
|
#:get-file-names
|
|
|
|
#:make-path
|
|
|
|
#:open-file
|
|
|
|
#:open-binary-file
|
|
|
|
#:open-text-file
|
|
|
|
#:remove-directory
|
|
|
|
#:remove-file
|
|
|
|
#:rename-content-file
|
|
|
|
#:rename-directory
|
|
|
|
#:store-file
|
|
|
|
#:store-text
|
|
|
|
#:store-with-raw-path
|
|
|
|
#:store-text-with-raw-path
|
|
|
|
#:open-text-file-with-raw-path
|
|
|
|
#:store-test
|
|
|
|
#:remove-file-with-raw-path
|
|
|
|
#:make-raw-path
|
|
|
|
#:ensure-raw-directory-exists
|
|
|
|
#:remove-raw-directory
|
|
|
|
#:copy-storage-directory
|
|
|
|
#:copy-raw-directory))
|
|
|
|
(in-package #:storage)
|
|
|
|
|
|
|
|
(defun init-storage ()
|
|
|
|
"Copies the initial files into their default places.
|
|
|
|
This is used as part of the /run-set defroute in web.lisp file."
|
|
|
|
(ensure-directory-exists "" "pages")
|
|
|
|
(uiop:copy-file (make-path "" "default-assets" "about")
|
|
|
|
(make-path "" "pages" "about"))
|
|
|
|
|
|
|
|
(uiop:copy-file (make-path "" "default-assets" "contact")
|
|
|
|
(make-path "" "pages" "contact"))
|
|
|
|
|
|
|
|
(uiop:copy-file (make-path "" "default-assets" "home")
|
|
|
|
(make-path "" "pages" "home"))
|
|
|
|
|
|
|
|
(uiop:copy-file (make-path "" "default-assets" "site-logo.png")
|
|
|
|
(merge-pathnames "static/images/site-logo.png"
|
|
|
|
ritherdon-archive.config:*application-root*))
|
|
|
|
(uiop:copy-file (make-path "" "default-assets" "favicon.png")
|
|
|
|
(merge-pathnames "static/images/favicon.png"
|
|
|
|
ritherdon-archive.config:*application-root*))
|
|
|
|
(ensure-directory-exists "" "snippets")
|
|
|
|
(uiop:copy-file (make-path "" "default-assets" "site-wide-snippet.html")
|
|
|
|
(make-path "" "snippets" "site-wide-snippet.html"))
|
|
|
|
;; Nothing is added to /storage/media yet, this is just prep. work.
|
|
|
|
(ensure-directory-exists "" "media")
|
|
|
|
(ensure-raw-directory-exists "snapshots/"))
|
|
|
|
|
|
|
|
(defun copy-storage-directory (target-path)
|
|
|
|
"Copies the contents of /storage directory to `TARGET-PATH'.
|
|
|
|
Make sure `TARGET-PATH' ends with a slash (E.G. snapshots/oct-2022/). Without
|
|
|
|
it, the system will assume you're trying to work with a file and throw an
|
|
|
|
error."
|
|
|
|
(copy-directory:copy (make-raw-path "storage/") (make-raw-path target-path)))
|
|
|
|
|
|
|
|
(defun copy-raw-directory (source-path target-path)
|
|
|
|
"Copies a directory (`SOURCE-PATH') outside of /storage to `TARGET-PATH'."
|
|
|
|
(copy-directory:copy (make-raw-path source-path) (make-raw-path target-path)))
|
|
|
|
|
|
|
|
(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-raw-directory-exists (directory-path)
|
|
|
|
"Creates directory if it doesn't exist (use for working outside of /storage).
|
|
|
|
The directories path is returned if it does exist and `NIL' is returned if the
|
|
|
|
directory cannot be found."
|
|
|
|
(ensure-directories-exist (make-raw-path directory-path)))
|
|
|
|
|
|
|
|
(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 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 make-raw-path (path)
|
|
|
|
"Make a file/directory path outsite of the /storage directory."
|
|
|
|
(merge-pathnames (format nil "~a" path)
|
|
|
|
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-raw-directory (directory-path)
|
|
|
|
"Removes directory at `DIRECTORY-PATH' when outside /storage directory."
|
|
|
|
(cl-fad:delete-directory-and-files (make-raw-path directory-path)))
|
|
|
|
|
|
|
|
(defun remove-directory (username subdirectory)
|
|
|
|
"Deletes an directory in /storage.
|
|
|
|
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-old (username subdirectory filename data)
|
|
|
|
"OBSOLETE. USE `STORE-FILE'."
|
|
|
|
(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-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 ((equal (type-of (car data)) 'SB-SYS:FD-STREAM)
|
|
|
|
(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))))
|
|
|
|
|
|
|
|
(defun store-with-raw-path (path data)
|
|
|
|
"Stores `DATA' at `PATH'. Use when storing data outsite of /storage directory."
|
|
|
|
(let ((path (ensure-directories-exist
|
|
|
|
(merge-pathnames path
|
|
|
|
ritherdon-archive.config::*application-root*))))
|
|
|
|
(cond ((equal (type-of (car data)) 'SB-SYS:FD-STREAM)
|
|
|
|
(uiop:copy-file (slot-value (car data) 'pathname) path))
|
|
|
|
(t
|
|
|
|
(with-open-file (stream
|
|
|
|
path
|
|
|
|
:direction :output
|
|
|
|
:element-type '(unsigned-byte 8)
|
|
|
|
:if-does-not-exist :create
|
|
|
|
:if-exists :supersede)
|
|
|
|
(write-sequence (slot-value (car data) 'vector) stream))))))
|
|
|
|
|
|
|
|
(defun store-text-with-raw-path (path data)
|
|
|
|
"Stores the plain text `DATA' at `PATH'.
|
|
|
|
Use when storing text outside of /storage direcory."
|
|
|
|
(let ((path (ensure-directories-exist
|
|
|
|
(merge-pathnames path
|
|
|
|
ritherdon-archive.config::*application-root*))))
|
|
|
|
(with-open-file (stream
|
|
|
|
path
|
|
|
|
:direction :output
|
|
|
|
:if-does-not-exist :create
|
|
|
|
:if-exists :supersede)
|
|
|
|
(format stream "~a~%" data))))
|
|
|
|
|
|
|
|
(defun open-text-file-with-raw-path (file-path)
|
|
|
|
"Reads the text file stored in the at `PATH'.
|
|
|
|
Use when reading text outside the /storage directory."
|
|
|
|
(let ((path (ensure-directories-exist
|
|
|
|
(merge-pathnames file-path
|
|
|
|
ritherdon-archive.config::*application-root*))))
|
|
|
|
(with-open-file (stream path)
|
|
|
|
(let ((data (make-string (file-length stream))))
|
|
|
|
(read-sequence data stream)
|
|
|
|
data))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun remove-file-with-raw-path (file-path)
|
|
|
|
"Deletes the specified file, at `PATH', use this to delete file outsite of /storage.
|
|
|
|
Before calling this function, make sure the file exists. You should have
|
|
|
|
'file-exists-p' available to you -- within this (storage) package."
|
|
|
|
(delete-file (merge-pathnames file-path ritherdon-archive.config::*application-root*)))
|
|
|
|
|
|
|
|
;;; 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)))))
|