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.
179 lines
7.3 KiB
179 lines
7.3 KiB
2 years ago
|
(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)))))
|