Public archive for the Return to Ritherdon project.
https://www.nicolaellisandritherdon.com
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
295 lines
12 KiB
295 lines
12 KiB
(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)))))
|
|
|