ritherdon-archive/src/storage.lisp

(in-package #:cl-user)
(defpackage #:storage
  (:use #:cl)
  (:export #:init-storage
	   #: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
	   #:store-with-raw-path
	   #:store-text-with-raw-path
	   #:open-text-file-with-raw-path
	   #:store-test))
(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*))
  (uiop:copy-file (make-path "" "default-assets" "site-wide-snippet")
		  (merge-pathnames "static/site-wide-snippet"
				   ritherdon-archive.config:*application-root*)))

(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-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))))

;;; 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)))))