Implement file systems and instructions in core
This commit is contained in:
HiPhish
parent
e5684b7f18
commit
0aa9d4fd69
18 changed files with 812 additions and 70 deletions
32
TODO.rst
32
TODO.rst
|
|
@ -8,6 +8,36 @@
|
||||||
Core
|
Core
|
||||||
####
|
####
|
||||||
|
|
||||||
|
New feature: file systems
|
||||||
|
=========================
|
||||||
|
|
||||||
|
Currently file output is strongly coupled to the file system of the OS. If we
|
||||||
|
want to write an artifact, then writing the artifact is the responsibility of
|
||||||
|
the artifact: it performs the low-level file system access, it generates the
|
||||||
|
output text and it manages the file names, including the output directory path.
|
||||||
|
|
||||||
|
My proposal is to add a lever of indirection by separating concerns. There are
|
||||||
|
three participants:
|
||||||
|
|
||||||
|
- File systems
|
||||||
|
- Artifacts
|
||||||
|
- Instructions
|
||||||
|
|
||||||
|
The artifact is an abstract representation of one or more future files. It is
|
||||||
|
then *derived* to produce a low-level instruction on what action to actually
|
||||||
|
perform to produce the file (relative file name, contents). The file system
|
||||||
|
interprets the instruction by accessing the file systems and outputting the
|
||||||
|
actual contents.
|
||||||
|
|
||||||
|
All this will be implemented using CLOS. A generic function dispatches on both
|
||||||
|
instruction and file system. There will be core implementations for elemental
|
||||||
|
instructions and file systems. Implementations for new classes will then be
|
||||||
|
implemented on top of these primitive methods. For example, an implementation
|
||||||
|
for an instruction which produces multiple files will created multiple
|
||||||
|
lower-level instructions and call the generic function for each of these
|
||||||
|
instructions and the original file system.
|
||||||
|
|
||||||
|
|
||||||
New feature: sources
|
New feature: sources
|
||||||
====================
|
====================
|
||||||
|
|
||||||
|
|
@ -35,6 +65,8 @@ Cleanup
|
||||||
|
|
||||||
- A proper public interface to the various artifact classes
|
- A proper public interface to the various artifact classes
|
||||||
- Expose reader interface to public
|
- Expose reader interface to public
|
||||||
|
- Remove `WRITE-ARTIFACT` generic function and its methods once file system and
|
||||||
|
instructions are implemented everywhere
|
||||||
|
|
||||||
Testing
|
Testing
|
||||||
=======
|
=======
|
||||||
|
|
|
||||||
11
hssg.asd
11
hssg.asd
|
|
@ -29,6 +29,7 @@
|
||||||
:components ((:module "hssg"
|
:components ((:module "hssg"
|
||||||
:components ((:file "package")
|
:components ((:file "package")
|
||||||
(:file "config")
|
(:file "config")
|
||||||
|
(:file "filesystem")
|
||||||
(:file "reader")
|
(:file "reader")
|
||||||
(:module "readers"
|
(:module "readers"
|
||||||
:components ((:file "lisp")))
|
:components ((:file "lisp")))
|
||||||
|
|
@ -53,12 +54,18 @@
|
||||||
:perform (test-op (o s)
|
:perform (test-op (o s)
|
||||||
(symbol-call :hssg/test :test-all))
|
(symbol-call :hssg/test :test-all))
|
||||||
:components ((:module "test"
|
:components ((:module "test"
|
||||||
:components ((:module "hssg"
|
:components ((:file "mocking")
|
||||||
|
(:module "hssg"
|
||||||
:components ((:file "package")
|
:components ((:file "package")
|
||||||
(:file "main")
|
(:file "main")
|
||||||
|
(:file "file-system")
|
||||||
(:file "template")
|
(:file "template")
|
||||||
(:file "reader")
|
(:file "reader")
|
||||||
(:module "readers"
|
(:module "readers"
|
||||||
:components ((:file "lisp")))
|
:components ((:file "lisp")))
|
||||||
(:module "artifacts"
|
(:module "artifacts"
|
||||||
:components ((:file "compound")))))))))
|
:components ((:file "compound")
|
||||||
|
(:file "directory")
|
||||||
|
(:file "html")
|
||||||
|
(:file "verbatim")
|
||||||
|
(:file "xml")))))))))
|
||||||
|
|
|
||||||
|
|
@ -22,3 +22,13 @@
|
||||||
(defgeneric write-artifact (artifact)
|
(defgeneric write-artifact (artifact)
|
||||||
(:documentation "Write the given ARTIFACT to disc. The artifact's state
|
(:documentation "Write the given ARTIFACT to disc. The artifact's state
|
||||||
determines where and how the artifact will be written."))
|
determines where and how the artifact will be written."))
|
||||||
|
|
||||||
|
(defgeneric derive-artifact (artifact)
|
||||||
|
(:documentation "Derives the GIVEN artifact to produce a file system instruction."))
|
||||||
|
|
||||||
|
(defun write-artifact* (artifact file-system)
|
||||||
|
"Derives the given ARTIFACT and writes it to the FILE-SYSTEM."
|
||||||
|
(declare (type file-system file-system))
|
||||||
|
(let ((instruction (derive-artifact artifact)))
|
||||||
|
(declare (type file-system-instruction instruction))
|
||||||
|
(write-to-filesystem instruction file-system)))
|
||||||
|
|
|
||||||
|
|
@ -20,17 +20,17 @@
|
||||||
(in-package #:hssg.artifact)
|
(in-package #:hssg.artifact)
|
||||||
|
|
||||||
(defclass verbatim-artifact ()
|
(defclass verbatim-artifact ()
|
||||||
((input :reader verbatim-artifact-input :initarg :input :type pathname
|
((file-name :initarg :file :type pathname
|
||||||
:documentation "Path to the file to copy")
|
:documentation "Original file name")
|
||||||
(output :initarg :output :type pathname
|
(directory :initarg :directory :type pathname
|
||||||
:documentation "Path where to write the produced artifact."))
|
:documentation "Base path to the file to copy, will not be copied"))
|
||||||
(:documentation "Artifact which copies one filed to another location"))
|
(:documentation "Artifact which copies one filed to another location"))
|
||||||
|
|
||||||
(defclass directory-artifact ()
|
(defclass directory-artifact ()
|
||||||
((input :reader directory-artifact-input :initarg :input :type pathname
|
((directory :initarg :directory :type pathname
|
||||||
:documentation "Path to the directory to copy recursively")
|
:documentation "Original directory path, relative to base directory")
|
||||||
(output :initarg :output :type pathname
|
(base :initarg :base :type pathname
|
||||||
:documentation "Path where to write the produced artifact."))
|
:documentation "Base path to the directory, will not be copied"))
|
||||||
(:documentation "Artifact which copies a directory and its contents recursively to another location"))
|
(:documentation "Artifact which copies a directory and its contents recursively to another location"))
|
||||||
|
|
||||||
(defclass compound-artifact ()
|
(defclass compound-artifact ()
|
||||||
|
|
|
||||||
|
|
@ -24,6 +24,11 @@
|
||||||
(dolist (artifact (slot-value wrapper 'hssg.artifact:artifacts))
|
(dolist (artifact (slot-value wrapper 'hssg.artifact:artifacts))
|
||||||
(hssg.artifact:write-artifact artifact)))
|
(hssg.artifact:write-artifact artifact)))
|
||||||
|
|
||||||
|
(defmethod hssg.artifact:derive-artifact ((artifact hssg.artifact:compound-artifact))
|
||||||
|
(with-slots ((artifacts hssg.artifact:artifacts)) artifact
|
||||||
|
(make-instance 'hssg.filesystem:compound-instruction
|
||||||
|
:instructions (mapcar #'hssg.artifact:derive-artifact artifacts))))
|
||||||
|
|
||||||
(defun make-compound-artifact (&rest artifacts)
|
(defun make-compound-artifact (&rest artifacts)
|
||||||
"Create a new compound artifact, which is a wrapper around the given
|
"Create a new compound artifact, which is a wrapper around the given
|
||||||
ARTIFACTS. Writing a compound artifact writes all the wrapped artifact in the
|
ARTIFACTS. Writing a compound artifact writes all the wrapped artifact in the
|
||||||
|
|
|
||||||
|
|
@ -36,13 +36,18 @@
|
||||||
(fad:copy-file pathname target :overwrite t))))))
|
(fad:copy-file pathname target :overwrite t))))))
|
||||||
nil)
|
nil)
|
||||||
|
|
||||||
(defun make-directory-artifact (file-path input-dir output-dir)
|
(defmethod hssg.artifact:derive-artifact ((artifact hssg.artifact:directory-artifact))
|
||||||
|
(with-slots ((path hssg.artifact::directory)
|
||||||
|
(base-path hssg.artifact::base))
|
||||||
|
artifact
|
||||||
|
(make-instance 'hssg.filesystem:copy-directory
|
||||||
|
:base-path (fad:pathname-as-directory base-path)
|
||||||
|
:path (fad:pathname-as-directory path))))
|
||||||
|
|
||||||
|
(defun make-directory-artifact (base directory)
|
||||||
"Constructor for a verbatim directory artifact which copies an entire
|
"Constructor for a verbatim directory artifact which copies an entire
|
||||||
directory FILE-PATH and its contents recursively from INPUT-DIR to
|
directory FILE-PATH and its contents recursively from INPUT-DIR to
|
||||||
OUTPUT-DIR."
|
OUTPUT-DIR."
|
||||||
(declare (type (or string pathname) file-path input-dir output-dir))
|
(declare (type (or string pathname) base directory))
|
||||||
(let ((input (merge-pathnames file-path (fad:pathname-as-directory input-dir)))
|
(make-instance 'hssg.artifact:directory-artifact
|
||||||
(output (merge-pathnames file-path (fad:pathname-as-directory output-dir))))
|
:base base :directory directory))
|
||||||
(make-instance 'hssg.artifact:directory-artifact
|
|
||||||
:input (fad:pathname-as-directory input)
|
|
||||||
:output (fad:pathname-as-directory output))))
|
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,30 @@
|
||||||
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
|
||||||
(in-package #:hssg.artifact.html)
|
(in-package #:hssg.artifact.html)
|
||||||
|
|
||||||
|
(defmethod hssg.artifact:write-artifact ((artifact hssg.artifact:html-artifact))
|
||||||
|
(with-slots ((data hssg.artifact::data)
|
||||||
|
(template hssg.artifact::template)
|
||||||
|
(output hssg.artifact::output))
|
||||||
|
artifact
|
||||||
|
(ensure-directories-exist output)
|
||||||
|
(with-open-file (*STANDARD-OUTPUT* output :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||||
|
(let ((plump:*tag-dispatchers* plump:*xml-tags*))
|
||||||
|
(format t "<!DOCTYPE html>~%")
|
||||||
|
(plump:serialize (sexp->plump-tree
|
||||||
|
(cdr (assoc :content (funcall template data)))))))))
|
||||||
|
|
||||||
|
(defmethod hssg.artifact:derive-artifact ((artifact hssg.artifact:html-artifact))
|
||||||
|
(with-slots ((data hssg.artifact::data)
|
||||||
|
(template hssg.artifact::template)
|
||||||
|
(output hssg.artifact::output))
|
||||||
|
artifact
|
||||||
|
(let ((contents (plump:serialize
|
||||||
|
(sexp->plump-tree (cdr (assoc :content (funcall template data))))
|
||||||
|
nil)))
|
||||||
|
(make-instance 'hssg.filesystem:write-string-contents
|
||||||
|
:contents (format nil "<!DOCTYPE html>~%~A" contents)
|
||||||
|
:path output))))
|
||||||
|
|
||||||
(defun read-html-lisp (fpath output &optional &key (template #'identity) (initial nil))
|
(defun read-html-lisp (fpath output &optional &key (template #'identity) (initial nil))
|
||||||
"Read the contents of an HTML document from a Lisp file."
|
"Read the contents of an HTML document from a Lisp file."
|
||||||
(declare (type (or string pathname) fpath output))
|
(declare (type (or string pathname) fpath output))
|
||||||
|
|
@ -76,18 +100,6 @@
|
||||||
(loop for child in tail when child do (sexp->plump-tree child node))
|
(loop for child in tail when child do (sexp->plump-tree child node))
|
||||||
node)))))
|
node)))))
|
||||||
|
|
||||||
(defmethod hssg.artifact:write-artifact ((artifact hssg.artifact:html-artifact))
|
|
||||||
(with-slots ((data hssg.artifact::data)
|
|
||||||
(template hssg.artifact::template)
|
|
||||||
(output hssg.artifact::output))
|
|
||||||
artifact
|
|
||||||
(ensure-directories-exist output)
|
|
||||||
(with-open-file (*STANDARD-OUTPUT* output :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
||||||
(let ((plump:*tag-dispatchers* plump:*xml-tags*))
|
|
||||||
(format t "<!DOCTYPE html>~%")
|
|
||||||
(plump:serialize (sexp->plump-tree
|
|
||||||
(cdr (assoc :content (funcall template data)))))))))
|
|
||||||
|
|
||||||
(defmacro static-page ((&rest bindings) &body content)
|
(defmacro static-page ((&rest bindings) &body content)
|
||||||
"Static page DSL macro
|
"Static page DSL macro
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -19,7 +19,7 @@
|
||||||
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
|
||||||
(in-package #:hssg.artifact.verbatim)
|
(in-package #:hssg.artifact.verbatim)
|
||||||
|
|
||||||
;;; Maybe this could be a public config parameter? I could be useful for other
|
;;; Maybe this could be a public config parameter? It could be useful for other
|
||||||
;;; file copy operations as well.
|
;;; file copy operations as well.
|
||||||
(defparameter *buffer-size* 512
|
(defparameter *buffer-size* 512
|
||||||
"Buffer size to use when copying a file. The file will be copied in chunks of
|
"Buffer size to use when copying a file. The file will be copied in chunks of
|
||||||
|
|
@ -33,10 +33,16 @@
|
||||||
(fad:copy-file input output :overwrite t)
|
(fad:copy-file input output :overwrite t)
|
||||||
nil))
|
nil))
|
||||||
|
|
||||||
(defun make-verbatim-artifact (file-path input-dir output-dir)
|
(defmethod hssg.artifact:derive-artifact ((artifact hssg.artifact:verbatim-artifact))
|
||||||
|
(with-slots ((file-name hssg.artifact::file-name)
|
||||||
|
(directory hssg.artifact::directory))
|
||||||
|
artifact
|
||||||
|
(make-instance 'hssg.filesystem:copy-file
|
||||||
|
:base-path (fad:pathname-as-directory directory)
|
||||||
|
:path (fad:pathname-as-file file-name))))
|
||||||
|
|
||||||
|
(defun make-verbatim-artifact (base-dir file-name)
|
||||||
"Constructor for a verbatim file artifact which copies to contents of
|
"Constructor for a verbatim file artifact which copies to contents of
|
||||||
FILE-PATH, relative to INPUT-DIR to the same path relative to OUTPUT-DIR."
|
FILE-PATH, relative to INPUT-DIR to the same path relative to OUTPUT-DIR."
|
||||||
(declare (type (or string pathname) file-path input-dir output-dir))
|
(declare (type (or string pathname) base-dir file-name))
|
||||||
(let* ((input (merge-pathnames file-path (fad:pathname-as-directory input-dir)))
|
(make-instance 'hssg.artifact:verbatim-artifact :directory base-dir :file file-name))
|
||||||
(output (merge-pathnames file-path (fad:pathname-as-directory output-dir))))
|
|
||||||
(make-instance 'hssg.artifact:verbatim-artifact :input input :output output)))
|
|
||||||
|
|
|
||||||
|
|
@ -26,6 +26,14 @@
|
||||||
(with-open-file (*STANDARD-OUTPUT* output :direction :output :if-exists :supersede :if-does-not-exist :create)
|
(with-open-file (*STANDARD-OUTPUT* output :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||||
(plump:serialize (sexp->xml-tree data)))))
|
(plump:serialize (sexp->xml-tree data)))))
|
||||||
|
|
||||||
|
(defmethod hssg.artifact:derive-artifact ((artifact hssg.artifact:xml-artifact))
|
||||||
|
(with-slots ((data hssg.artifact::data)
|
||||||
|
(output hssg.artifact::output))
|
||||||
|
artifact
|
||||||
|
(make-instance 'hssg.filesystem:write-string-contents
|
||||||
|
:contents (plump:serialize (sexp->xml-tree data) nil)
|
||||||
|
:path output)))
|
||||||
|
|
||||||
(defun sexp->xml-tree (sexp &key (version "1.0") (encoding "UTF-8"))
|
(defun sexp->xml-tree (sexp &key (version "1.0") (encoding "UTF-8"))
|
||||||
"Converts one s-expression tree to an XML document tree. All the neccessary
|
"Converts one s-expression tree to an XML document tree. All the neccessary
|
||||||
attributes of the XML header node will set from the (optional) keyword
|
attributes of the XML header node will set from the (optional) keyword
|
||||||
|
|
|
||||||
193
src/hssg/filesystem.lisp
Normal file
193
src/hssg/filesystem.lisp
Normal file
|
|
@ -0,0 +1,193 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; filesystem.lisp File system abstraction layer
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.(in-package #:hssg.artifact)
|
||||||
|
(in-package #:hssg.filesystem)
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- ABSTRACT CLASS DEFINITIONS --------------------------------------------
|
||||||
|
(defclass file-system ()
|
||||||
|
()
|
||||||
|
(:documentation "Abstract base class of all file systems."))
|
||||||
|
|
||||||
|
(defclass file-system-instruction ()
|
||||||
|
()
|
||||||
|
(:documentation "Abstract base class of all file system instructions"))
|
||||||
|
|
||||||
|
(defclass path-instruction (file-system-instruction)
|
||||||
|
((path :initarg :path :reader instruction-path :type pathname
|
||||||
|
:documentation "Path to the output file"))
|
||||||
|
(:documentation "An instruction which accesses exactly one file."))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- PROTOCOL --------------------------------------------------------------
|
||||||
|
(defgeneric write-to-filesystem (instruction file-system)
|
||||||
|
(:documentation
|
||||||
|
"Applies the given INSTRUCTION to the given FILE-SYSTEM, for side effects."))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- FILE SYSTEM CLASSES ---------------------------------------------------
|
||||||
|
(defclass base-file-system (file-system)
|
||||||
|
((directory :initarg :directory :reader file-system-directory :type pathname
|
||||||
|
:documentation "Actual directory within the file system."))
|
||||||
|
(:documentation
|
||||||
|
"A file system which accesses files of the host OS relative to a given base
|
||||||
|
directory."))
|
||||||
|
|
||||||
|
(defclass overlay-file-system (file-system)
|
||||||
|
((directory :initarg :directory :type pathname
|
||||||
|
:documentation "Directory of the file system relative to parent.")
|
||||||
|
(parent :initarg :parent :type (or overlay-file-system base-file-system)
|
||||||
|
:documentation "Parent file system."))
|
||||||
|
(:documentation
|
||||||
|
"File system whose operations are all relative to a parent file system."))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- INSTRUCTION CLASSES ---------------------------------------------------
|
||||||
|
(defclass write-string-contents (path-instruction)
|
||||||
|
((contents :initarg :contents :initform (make-string 0) :type string
|
||||||
|
:documentation "The file content as a string")))
|
||||||
|
|
||||||
|
(defclass copy-file (path-instruction)
|
||||||
|
((base-path :initarg :base-path :type pathname
|
||||||
|
:documentation "Path to the directory containing the file."))
|
||||||
|
(:documentation
|
||||||
|
"Instruction which copies a given file varbatim. The file will be copied
|
||||||
|
from BASE-PATH/PATH to PATH. The file system is responsible to prepending a new
|
||||||
|
base path to the output file."))
|
||||||
|
|
||||||
|
(defclass copy-directory (path-instruction)
|
||||||
|
((base-path :initarg :base-path :type pathname
|
||||||
|
:documentation "Path to the directory."))
|
||||||
|
(:documentation
|
||||||
|
"Instruction which copies a given directory recursively. The directory will
|
||||||
|
be copied from BASE-PATH/PATH to PATH. The file system is responsible for
|
||||||
|
prepending a new base path to the output file."))
|
||||||
|
|
||||||
|
|
||||||
|
(defclass compound-instruction (file-system-instruction)
|
||||||
|
((instructions :initarg :instructions :initform (list) :type list
|
||||||
|
:documentation "List of instrunctions to perform."))
|
||||||
|
(:documentation "Container instruction which wraps several instructions."))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- HELPER FUNCTIONS ------------------------------------------------------
|
||||||
|
;;; These functions encapsulate the lowest possible level of abstraction away
|
||||||
|
;;; from the actual file system I/O. They should be mocked during tests of
|
||||||
|
;;; dependent code, and tested individually on their own (even though they are
|
||||||
|
;;; not part of the public package interface).
|
||||||
|
(defun copy-file (from to)
|
||||||
|
"Copies the file at FROM to location TO, overwriting it if necessary."
|
||||||
|
(declare (type pathname from to))
|
||||||
|
(ensure-directories-exist to)
|
||||||
|
(fad:copy-file from to :overwrite t)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun copy-directory (from to)
|
||||||
|
"Recursively copies the contents of FROM to directory TO, overwriting it if
|
||||||
|
necessary."
|
||||||
|
(fad:walk-directory
|
||||||
|
from
|
||||||
|
(lambda (pathname)
|
||||||
|
(let* ((relative (enough-namestring pathname from))
|
||||||
|
(target (merge-pathnames relative to)))
|
||||||
|
(ensure-directories-exist target)
|
||||||
|
(fad:copy-file pathname target :overwrite t))))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun write-string-to-file (contents path)
|
||||||
|
"Writes the string CONTENTS to the file at PATH, creating it if necessary."
|
||||||
|
(declare (type string contents)
|
||||||
|
(type pathname path))
|
||||||
|
(ensure-directories-exist path)
|
||||||
|
(with-open-file (out path :direction :output :if-exists :supersede
|
||||||
|
:if-does-not-exist :create)
|
||||||
|
(write-string contents out))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun file-system-path (filesystem)
|
||||||
|
"The absolute path of a file system, either a BASE-FILE-SYSTEM or an
|
||||||
|
OVERLAY-FILE-SYSTEM. Multiple overlay file systems can be nested on top of
|
||||||
|
another."
|
||||||
|
(declare (type (or base-file-system overlay-file-system) filesystem))
|
||||||
|
(etypecase filesystem
|
||||||
|
(base-file-system
|
||||||
|
(fad:pathname-as-directory (slot-value filesystem 'directory)))
|
||||||
|
(overlay-file-system
|
||||||
|
(with-slots (directory parent) filesystem
|
||||||
|
(fad:merge-pathnames-as-directory
|
||||||
|
(file-system-path parent)
|
||||||
|
(fad:pathname-as-directory directory))))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- IMPLEMENTATIONS -------------------------------------------------------
|
||||||
|
(defmethod write-to-filesystem ((instruction write-string-contents)
|
||||||
|
(file-system base-file-system))
|
||||||
|
"A primitive implementation producing one file for fixed contents and an
|
||||||
|
absolute file system."
|
||||||
|
(let ((path (fad:merge-pathnames-as-file
|
||||||
|
(fad:pathname-as-directory (file-system-directory file-system))
|
||||||
|
(instruction-path instruction))))
|
||||||
|
(with-slots (contents) instruction
|
||||||
|
(write-string-to-file contents path))))
|
||||||
|
|
||||||
|
(defmethod write-to-filesystem ((instruction copy-file)
|
||||||
|
(file-system base-file-system))
|
||||||
|
"Copies a file verbatim relative to a base directory."
|
||||||
|
(with-slots (path base-path file) instruction
|
||||||
|
(with-slots (directory) file-system
|
||||||
|
(let ((original (fad:merge-pathnames-as-file
|
||||||
|
(fad:pathname-as-directory base-path) path))
|
||||||
|
(copy (fad:merge-pathnames-as-file
|
||||||
|
(fad:pathname-as-directory directory) path)))
|
||||||
|
(copy-file original copy)))))
|
||||||
|
|
||||||
|
(defmethod write-to-filesystem ((instruction copy-directory)
|
||||||
|
(file-system base-file-system))
|
||||||
|
"Copies a directory recursively to a base directory."
|
||||||
|
;; NOTE: This could have been implemented by walking over the source
|
||||||
|
;; directory and creating a COPY-FILE instruction for each file, but I
|
||||||
|
;; decided copy the directory directly instead. This is more efficient
|
||||||
|
;; because it does not create a number of intermediate instructions, and it
|
||||||
|
;; is easier to test because the function which accesses the physical file
|
||||||
|
;; system is isolated and can be mocked.
|
||||||
|
(with-slots (path base-path) instruction
|
||||||
|
(with-slots (directory) file-system
|
||||||
|
(let ((from (fad:merge-pathnames-as-directory
|
||||||
|
(fad:pathname-as-directory base-path)
|
||||||
|
(fad:pathname-as-directory path)))
|
||||||
|
(to (fad:merge-pathnames-as-directory
|
||||||
|
(fad:pathname-as-directory directory)
|
||||||
|
(fad:pathname-as-directory path))))
|
||||||
|
(copy-directory from to)))))
|
||||||
|
|
||||||
|
(defmethod write-to-filesystem (instruction
|
||||||
|
(file-system overlay-file-system))
|
||||||
|
"Reduces the overlay file system first, then applies instructions to the
|
||||||
|
reduced one."
|
||||||
|
(let ((directory (file-system-path file-system)))
|
||||||
|
(write-to-filesystem
|
||||||
|
instruction
|
||||||
|
(make-instance 'base-file-system :directory directory))))
|
||||||
|
|
||||||
|
(defmethod write-to-filesystem ((instruction compound-instruction)
|
||||||
|
file-system)
|
||||||
|
(with-slots (instructions) instruction
|
||||||
|
(dolist (instruction instructions)
|
||||||
|
(declare (type file-system-instruction instruction))
|
||||||
|
(write-to-filesystem instruction file-system))))
|
||||||
|
|
@ -18,6 +18,17 @@
|
||||||
;;;; You should have received a copy of the GNU Affero General Public License
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
(defpackage #:hssg.filesystem
|
||||||
|
(:documentation "File system abstraction.")
|
||||||
|
(:use :cl)
|
||||||
|
(:export #:file-system #:base-file-system #:overlay-file-system
|
||||||
|
#:file-system-instruction
|
||||||
|
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction
|
||||||
|
#:write-to-filesystem))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
(defpackage #:hssg.reader
|
(defpackage #:hssg.reader
|
||||||
(:documentation "Interface to the various content readers.")
|
(:documentation "Interface to the various content readers.")
|
||||||
(:use :cl)
|
(:use :cl)
|
||||||
|
|
@ -26,9 +37,12 @@
|
||||||
(defpackage #:hssg.artifact
|
(defpackage #:hssg.artifact
|
||||||
(:documentation "Helper package, defines the artifact protocl.")
|
(:documentation "Helper package, defines the artifact protocl.")
|
||||||
(:use #:cl)
|
(:use #:cl)
|
||||||
(:export write-artifact artifacts
|
(:import-from #:hssg.filesystem
|
||||||
|
#:file-system-instruction #:file-system #:write-to-filesystem)
|
||||||
|
(:export #:write-artifact #:derive-artifact artifacts
|
||||||
compound-artifact verbatim-artifact directory-artifact html-artifact xml-artifact))
|
compound-artifact verbatim-artifact directory-artifact html-artifact xml-artifact))
|
||||||
|
|
||||||
|
|
||||||
;;; ---------------------------------------------------------------------------
|
;;; ---------------------------------------------------------------------------
|
||||||
(defpackage #:hssg.artifact._compound
|
(defpackage #:hssg.artifact._compound
|
||||||
(:documentation "Implementatio of compound HSSG artifacts.")
|
(:documentation "Implementatio of compound HSSG artifacts.")
|
||||||
|
|
@ -64,6 +78,11 @@
|
||||||
(defpackage #:hssg
|
(defpackage #:hssg
|
||||||
(:documentation "The hackable static site generator")
|
(:documentation "The hackable static site generator")
|
||||||
(:use #:cl)
|
(:use #:cl)
|
||||||
|
(:import-from #:hssg.filesystem
|
||||||
|
#:file-system #:base-file-system #:overlay-file-system
|
||||||
|
#:file-system-instruction
|
||||||
|
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction
|
||||||
|
#:write-to-filesystem)
|
||||||
(:import-from #:hssg.artifact write-artifact artifacts html-artifact xml-artifact )
|
(:import-from #:hssg.artifact write-artifact artifacts html-artifact xml-artifact )
|
||||||
(:import-from #:hssg.artifact._compound make-compound-artifact compound-artifact-push)
|
(:import-from #:hssg.artifact._compound make-compound-artifact compound-artifact-push)
|
||||||
(:import-from #:hssg.artifact.directory make-directory-artifact)
|
(:import-from #:hssg.artifact.directory make-directory-artifact)
|
||||||
|
|
@ -73,6 +92,11 @@
|
||||||
chain-templates template-with-data)
|
chain-templates template-with-data)
|
||||||
(:export
|
(:export
|
||||||
*site-url* *site-language*
|
*site-url* *site-language*
|
||||||
|
;; File system
|
||||||
|
#:file-system #:base-file-system #:overlay-file-system
|
||||||
|
#:file-system-instruction
|
||||||
|
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction
|
||||||
|
#:write-to-filesystem
|
||||||
;; Artifact protocol
|
;; Artifact protocol
|
||||||
write-artifact
|
write-artifact
|
||||||
;; Compound artifacts
|
;; Compound artifacts
|
||||||
|
|
|
||||||
|
|
@ -16,53 +16,93 @@
|
||||||
;;;; more details.
|
;;;; more details.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; You should have received a copy of the GNU Affero General Public License
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.(in-package #:hssg.artifact)
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>
|
||||||
(defpackage #:hssg/test/artifact/compound
|
(defpackage #:hssg/test/artifact/compound
|
||||||
(:use #:cl))
|
(:use #:cl)
|
||||||
|
(:import-from #:clunit
|
||||||
|
#:defsuite #:deffixture #:deftest #:assert-equal #:assert-true #:assert-eql)
|
||||||
|
(:import-from #:hssg #:make-compound-artifact)
|
||||||
|
(:import-from #:hssg.filesystem))
|
||||||
(in-package #:hssg/test/artifact/compound)
|
(in-package #:hssg/test/artifact/compound)
|
||||||
|
|
||||||
;;; "Compound artifact implementation tests")
|
;;; Compound artifact implementation tests
|
||||||
(clunit:defsuite hssg.artifact.compound (hssg/test:hssg))
|
(clunit:defsuite hssg.artifact.compound (hssg/test:hssg))
|
||||||
|
(clunit:defsuite hssg.artifact.compound.constructor (hssg.artifact.compound))
|
||||||
|
(clunit:defsuite hssg.artifact.compound.mutation (hssg.artifact.compound))
|
||||||
|
(clunit:defsuite hssg.artifact.compound.derivation (hssg.artifact.compound))
|
||||||
|
|
||||||
|
|
||||||
;;; ---------------------------------------------------------------------------
|
;;; --- FAKES -----------------------------------------------------------------
|
||||||
(defstruct counter
|
|
||||||
"A mutable counter to keep track of how often the dummy artifact has been
|
|
||||||
written."
|
|
||||||
(count 0))
|
|
||||||
|
|
||||||
(defclass dummy-artifact ()
|
(defclass dummy-artifact ()
|
||||||
((counter :initarg :counter :accessor dummy-counter
|
()
|
||||||
:documentation "A (possibly shared) counter instance"))
|
(:documentation "A fake artifact"))
|
||||||
(:documentation "A fake artifact which increments its counter"))
|
|
||||||
|
|
||||||
(defmethod hssg:write-artifact ((dummy dummy-artifact))
|
(defclass dummy-instruction ()
|
||||||
(incf (counter-count (dummy-counter dummy)))
|
((artifact :initarg :artifact :reader dummy-artifact))
|
||||||
:ok)
|
(:documentation "A fake instruction"))
|
||||||
|
|
||||||
(clunit:deffixture hssg.artifact.compound (@body)
|
(defmethod hssg.artifact:derive-artifact ((artifact dummy-artifact))
|
||||||
(let ((counter (make-counter)))
|
"Attach the artifact to the instruction so we can check it was called."
|
||||||
@body))
|
(make-instance 'dummy-instruction :artifact artifact))
|
||||||
|
|
||||||
|
|
||||||
(clunit:deftest create-and-write (hssg.artifact.compound)
|
;;; --- CONSTRUCTOR -----------------------------------------------------------
|
||||||
"Writing a compound artifacts writes all all of its artifacts"
|
(deftest make-empty (hssg.artifact.compound.constructor)
|
||||||
(let ((artifact (hssg:make-compound-artifact
|
"An empty artifact has no children."
|
||||||
(make-instance 'dummy-artifact :counter counter)
|
(let ((compound (hssg:make-compound-artifact)))
|
||||||
(make-instance 'dummy-artifact :counter counter)
|
(with-slots ((artifacts hssg.artifact:artifacts))
|
||||||
(make-instance 'dummy-artifact :counter counter))))
|
compound
|
||||||
(hssg:write-artifact artifact))
|
(clunit:assert-false artifacts))))
|
||||||
(let ((count (counter-count counter)))
|
|
||||||
(clunit:assert-eql 3 count count)))
|
|
||||||
|
|
||||||
(clunit:deftest push-artifact (hssg.artifact.compound)
|
(deftest make-nonempty (hssg.artifact.compound.constructor)
|
||||||
|
"A nonempty artifact has children."
|
||||||
|
(let* ((dummy1 (make-instance 'dummy-artifact))
|
||||||
|
(dummy2 (make-instance 'dummy-artifact))
|
||||||
|
(compound (hssg:make-compound-artifact dummy1 dummy2)))
|
||||||
|
(with-slots ((artifacts hssg.artifact:artifacts))
|
||||||
|
compound
|
||||||
|
(assert-eql 2 (length artifacts))
|
||||||
|
(loop for artifact in artifacts
|
||||||
|
for dummy in (list dummy1 dummy2)
|
||||||
|
do (assert-true (eq dummy artifact))))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- MUTATION --------------------------------------------------------------
|
||||||
|
(deftest push-artifact (hssg.artifact.compound.mutation)
|
||||||
"Push a new artifact onto the list of wrapped artifacts"
|
"Push a new artifact onto the list of wrapped artifacts"
|
||||||
(let ((compound (hssg:make-compound-artifact))
|
(let ((compound (hssg:make-compound-artifact))
|
||||||
(dummy1 (make-instance 'dummy-artifact :counter counter))
|
(dummy1 (make-instance 'dummy-artifact))
|
||||||
(dummy2 (make-instance 'dummy-artifact :counter counter)))
|
(dummy2 (make-instance 'dummy-artifact)))
|
||||||
(hssg:compound-artifact-push compound dummy1)
|
|
||||||
(hssg:compound-artifact-push compound dummy2)
|
(hssg:compound-artifact-push compound dummy2)
|
||||||
(hssg:write-artifact compound))
|
(hssg:compound-artifact-push compound dummy1)
|
||||||
(clunit:assert-eql 2 (counter-count counter)))
|
(with-slots ((artifacts hssg.artifact:artifacts))
|
||||||
|
compound
|
||||||
|
(assert-eql 2 (length artifacts))
|
||||||
|
(loop for artifact in artifacts
|
||||||
|
for dummy in (list dummy1 dummy2)
|
||||||
|
do (assert-true (eq dummy artifact))))))
|
||||||
|
|
||||||
(hssg/test:test-all)
|
|
||||||
|
;;; --- DERIVATIVES -----------------------------------------------------------
|
||||||
|
(deftest derive-empty (hssg.artifact.compound.derivation)
|
||||||
|
"Deriving an empty artifact yields and empty struction."
|
||||||
|
(let* ((artifact (hssg:make-compound-artifact))
|
||||||
|
(instruction (hssg.artifact:derive-artifact artifact)))
|
||||||
|
(assert-true (typep instruction 'hssg.filesystem:compound-instruction))
|
||||||
|
(with-slots ((instructions hssg.filesystem::instructions))
|
||||||
|
instruction
|
||||||
|
(null instructions))))
|
||||||
|
|
||||||
|
(deftest derive-nonempty (hssg.artifact.compound.derivation)
|
||||||
|
"Deriving a non-empty artifact in turn derives each of the children."
|
||||||
|
(let* ((dummy1 (make-instance 'dummy-artifact))
|
||||||
|
(dummy2 (make-instance 'dummy-artifact))
|
||||||
|
(artifact (hssg:make-compound-artifact dummy1 dummy2))
|
||||||
|
(instruction (hssg.artifact:derive-artifact artifact)))
|
||||||
|
(assert-true (typep instruction 'hssg.filesystem:compound-instruction))
|
||||||
|
(with-slots ((instructions hssg.filesystem::instructions))
|
||||||
|
instruction
|
||||||
|
(assert-eql 2 (length instructions))
|
||||||
|
(loop for instruction in instructions
|
||||||
|
for dummy in (list dummy1 dummy2)
|
||||||
|
do (assert-true (eq dummy (dummy-artifact instruction)))))))
|
||||||
|
|
|
||||||
38
test/hssg/artifacts/directory.lisp
Normal file
38
test/hssg/artifacts/directory.lisp
Normal file
|
|
@ -0,0 +1,38 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; directory.lisp Varbatim artifact tests
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>
|
||||||
|
(defpackage #:hssg/test/artifact/directory
|
||||||
|
(:use #:cl)
|
||||||
|
(:import-from #:clunit #:defsuite #:deffixture #:deftest #:assert-equal #:assert-true)
|
||||||
|
(:import-from #:hssg.artifact #:directory-artifact #:derive-artifact))
|
||||||
|
(in-package #:hssg/test/artifact/directory)
|
||||||
|
|
||||||
|
(clunit:defsuite hssg.artifact.directory (hssg/test:hssg))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
(deftest derive-artifact (hssg.artifact.directory)
|
||||||
|
(let* ((artifact (hssg:make-directory-artifact #p"content/blog" #p"assets/images"))
|
||||||
|
(instruction (hssg.artifact:derive-artifact artifact)))
|
||||||
|
(assert-true (typep instruction 'hssg:copy-directory))
|
||||||
|
(with-slots ((base-path hssg.filesystem::base-path)
|
||||||
|
(path hssg.filesystem::path))
|
||||||
|
instruction
|
||||||
|
(assert-equal #p"content/blog/" base-path)
|
||||||
|
(assert-equal #p"assets/images/" path))))
|
||||||
52
test/hssg/artifacts/html.lisp
Normal file
52
test/hssg/artifacts/html.lisp
Normal file
|
|
@ -0,0 +1,52 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; html.lisp HTML artifact tests
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>
|
||||||
|
(defpackage #:hssg/test/artifact/html
|
||||||
|
(:use #:cl)
|
||||||
|
(:import-from #:clunit #:defsuite #:deffixture #:deftest #:assert-equal #:assert-true)
|
||||||
|
(:import-from #:hssg.artifact #:html-artifact #:derive-artifact))
|
||||||
|
(in-package #:hssg/test/artifact/html)
|
||||||
|
|
||||||
|
(clunit:defsuite hssg.artifact.html (hssg/test:hssg))
|
||||||
|
|
||||||
|
(hssg:deftemplate dummy-template (content)
|
||||||
|
(:content
|
||||||
|
`(:html
|
||||||
|
(:head)
|
||||||
|
(:body
|
||||||
|
,@content))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
(deftest derive-artifact (hssg.artifact.html)
|
||||||
|
(let* ((artifact (make-instance 'hssg:html-artifact
|
||||||
|
:data '((:content . ((:p "Hello world!"))))
|
||||||
|
:template #'dummy-template
|
||||||
|
:output #p"blog/index.html"))
|
||||||
|
(instruction (derive-artifact artifact)))
|
||||||
|
nil
|
||||||
|
(assert-true (typep instruction 'hssgwrite-string-contents))
|
||||||
|
(with-slots ((contents hssg.filesystem::contents)
|
||||||
|
(path hssg.filesystem::path))
|
||||||
|
instruction
|
||||||
|
nil
|
||||||
|
(assert-equal "<!DOCTYPE html>
|
||||||
|
<html><head></head><body><p>Hello world!</p></body></html>"
|
||||||
|
contents)
|
||||||
|
(assert-equal #p"blog/index.html" path))))
|
||||||
51
test/hssg/artifacts/verbatim.lisp
Normal file
51
test/hssg/artifacts/verbatim.lisp
Normal file
|
|
@ -0,0 +1,51 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; verbatim.lisp Varbatim artifact tests
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>
|
||||||
|
(defpackage #:hssg/test/artifact/verbatim
|
||||||
|
(:use #:cl)
|
||||||
|
(:import-from #:clunit #:defsuite #:deffixture #:deftest #:assert-equal)
|
||||||
|
(:import-from #:hssg.artifact #:verbatim-artifact #:derive-artifact))
|
||||||
|
(in-package #:hssg/test/artifact/verbatim)
|
||||||
|
|
||||||
|
(clunit:defsuite hssg.artifact.verbatim (hssg/test:hssg))
|
||||||
|
(clunit:defsuite hssg.artifact.verbatim.constructor (hssg.artifact.verbatim))
|
||||||
|
(clunit:defsuite hssg.artifact.verbatim.deriving (hssg.artifact.verbatim))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
(deftest constructor-function (hssg.artifact.verbatim.constructor)
|
||||||
|
(let ((base-dir #p"content/blog")
|
||||||
|
(file-name #p"css/main.css"))
|
||||||
|
(let ((artifact (hssg:make-verbatim-artifact base-dir file-name)))
|
||||||
|
(with-slots ((directory hssg.artifact::directory)
|
||||||
|
(file-name hssg.artifact::file-name))
|
||||||
|
artifact
|
||||||
|
(assert-equal #p"content/blog" directory)
|
||||||
|
(assert-equal #p"css/main.css" file-name)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
(deftest derive-artifact (hssg.artifact.verbatim.deriving)
|
||||||
|
(let* ((artifact (hssg:make-verbatim-artifact #p"content/blog" #p"css/main.css"))
|
||||||
|
(instruction (derive-artifact artifact)))
|
||||||
|
(with-slots ((base-path hssg.filesystem::base-path)
|
||||||
|
(path hssg.filesystem::path))
|
||||||
|
instruction
|
||||||
|
(assert-equal #p"content/blog/" base-path)
|
||||||
|
(assert-equal #p"css/main.css" path))))
|
||||||
41
test/hssg/artifacts/xml.lisp
Normal file
41
test/hssg/artifacts/xml.lisp
Normal file
|
|
@ -0,0 +1,41 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; xml.lisp XML artifact tests
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>
|
||||||
|
(defpackage #:hssg/test/artifact/xml
|
||||||
|
(:use #:cl)
|
||||||
|
(:import-from #:clunit #:defsuite #:deffixture #:deftest #:assert-equal #:assert-true)
|
||||||
|
(:import-from #:hssg.artifact #:xml-artifact #:derive-artifact))
|
||||||
|
(in-package #:hssg/test/artifact/xml)
|
||||||
|
|
||||||
|
(clunit:defsuite hssg.artifact.xml (hssg/test:hssg))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
;;; NOTE: we do not test the produced XML, only that some XML was produced in
|
||||||
|
;;; the first place.
|
||||||
|
|
||||||
|
(deftest derive-artifact (hssg.artifact.xml)
|
||||||
|
(let* ((artifact (make-instance 'hssg:xml-artifact :data '((:foo . "bar")) :output #p"blog/rss.xml"))
|
||||||
|
(instruction (derive-artifact artifact)))
|
||||||
|
(assert-true (typep instruction 'hssg:write-string-contents))
|
||||||
|
(with-slots ((contents hssg.filesystem::contents)
|
||||||
|
(path hssg.filesystem::path))
|
||||||
|
instruction
|
||||||
|
(assert-equal "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo></foo>" contents)
|
||||||
|
(assert-equal #p"blog/rss.xml" path))))
|
||||||
162
test/hssg/file-system.lisp
Normal file
162
test/hssg/file-system.lisp
Normal file
|
|
@ -0,0 +1,162 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; file-system.lisp File system implementation tests
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>
|
||||||
|
(defpackage #:hssg/test/filesystem
|
||||||
|
(:documentation "File system implementation tests")
|
||||||
|
(:use #:cl)
|
||||||
|
(:import-from #:clunit
|
||||||
|
#:defsuite #:deffixture #:deftest #:assert-true #:assert-eql #:assert-equal)
|
||||||
|
(:import-from #:hssg/test-mocking #:with-mock)
|
||||||
|
(:export test-all all-tests hssg))
|
||||||
|
(in-package #:hssg/test/filesystem)
|
||||||
|
|
||||||
|
(defsuite hssg.filesystem (hssg/test:hssg))
|
||||||
|
(defsuite hssg.filesystem.get-path (hssg.filesystem))
|
||||||
|
(defsuite hssg.filesystem.write (hssg.filesystem))
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- FAKES -----------------------------------------------------------------
|
||||||
|
(defclass dummy-instruction (hssg:file-system-instruction)
|
||||||
|
((on-write :initarg :on-write :initform (lambda (self) self)
|
||||||
|
:documentation "Callback to execute when the instruction is written."))
|
||||||
|
(:documentation "A fake file system instruction"))
|
||||||
|
|
||||||
|
(defclass dummy-filesystem (hssg:file-system)
|
||||||
|
()
|
||||||
|
(:documentation "A fake file system"))
|
||||||
|
|
||||||
|
(defmethod hssg:write-to-filesystem ((instruction dummy-instruction)
|
||||||
|
file-system)
|
||||||
|
(funcall (slot-value instruction 'on-write) instruction))
|
||||||
|
|
||||||
|
(defmethod hssg:write-to-filesystem (instruction
|
||||||
|
(file-system dummy-filesystem))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
|
||||||
|
;;; --- FILE SYSTEM TESTS -----------------------------------------------------
|
||||||
|
(deffixture hssg.filesystem.get-path (@body)
|
||||||
|
"Creates a dummy base file system"
|
||||||
|
(let* ((base
|
||||||
|
(make-instance 'hssg:base-file-system :directory #p"base"))
|
||||||
|
(overlay1
|
||||||
|
(make-instance
|
||||||
|
'hssg:overlay-file-system :directory #p"overlay-1" :parent base))
|
||||||
|
(overlay2
|
||||||
|
(make-instance
|
||||||
|
'hssg:overlay-file-system :directory #p"overlay-2" :parent overlay1)))
|
||||||
|
(declare (ignorable base overlay1 overlay2))
|
||||||
|
@body))
|
||||||
|
|
||||||
|
(deftest base-file-system-path (hssg.filesystem.get-path)
|
||||||
|
"The path of a base file system is its slot value."
|
||||||
|
(let ((path (hssg.filesystem::file-system-path base)))
|
||||||
|
(assert-equal #p"base/" path)))
|
||||||
|
|
||||||
|
(deftest single-overlay-file-system-path (hssg.filesystem.get-path)
|
||||||
|
"The path of an overlay file system is the merge of its own and the parent's path."
|
||||||
|
(let ((path (hssg.filesystem::file-system-path overlay1)))
|
||||||
|
(assert-equal #p"base/overlay-1/" path)))
|
||||||
|
|
||||||
|
(deftest multi-overlay-file-system-path (hssg.filesystem.get-path)
|
||||||
|
"An overlay on top of an overlay merges all its parent file systems"
|
||||||
|
(let ((path (hssg.filesystem::file-system-path overlay2)))
|
||||||
|
(assert-equal #p"base/overlay-1/overlay-2/" path)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ---------------------------------------------------------------------------
|
||||||
|
(deffixture hssg.filesystem.write (@body)
|
||||||
|
"Creates a counter variable to keep track of mock calls."
|
||||||
|
(let ((counter 0))
|
||||||
|
(declare (ignorable counter))
|
||||||
|
@body))
|
||||||
|
|
||||||
|
(deftest write/copy-file/base-filesystem (hssg.filesystem.write)
|
||||||
|
"Copying a file verbatim to a base file system"
|
||||||
|
(let ((file-system (make-instance 'hssg:base-file-system :directory #p"output"))
|
||||||
|
(instruction (make-instance 'hssg:copy-file :path #p"css/main.css" :base-path #p"content")))
|
||||||
|
(with-mock ((hssg.filesystem::copy-file
|
||||||
|
(lambda (original copy)
|
||||||
|
(incf counter)
|
||||||
|
(assert-equal #p"content/css/main.css" original)
|
||||||
|
(assert-equal #p"output/css/main.css" copy))))
|
||||||
|
(hssg:write-to-filesystem instruction file-system)
|
||||||
|
(assert-eql 1 counter))))
|
||||||
|
|
||||||
|
(deftest write/write-string/base-filesystem (hssg.filesystem.write)
|
||||||
|
"Writing a string to a file in a base file system"
|
||||||
|
(let ((file-system (make-instance 'hssg:base-file-system
|
||||||
|
:directory #p"output"))
|
||||||
|
(instruction (make-instance 'hssg:write-string-contents
|
||||||
|
:path #p"css/main.css"
|
||||||
|
:contents "Hello world")))
|
||||||
|
(with-mock ((hssg.filesystem::write-string-to-file
|
||||||
|
(lambda (contents path)
|
||||||
|
(incf counter)
|
||||||
|
(assert-equal "Hello world" contents)
|
||||||
|
(assert-equal #p"output/css/main.css" path))))
|
||||||
|
(hssg:write-to-filesystem instruction file-system)
|
||||||
|
(assert-eql 1 counter))))
|
||||||
|
|
||||||
|
(deftest write/write-string/overlay-filesystem (hssg.filesystem.write)
|
||||||
|
"Writing a string to an overlay file system resolved the path correctly."
|
||||||
|
(let ((file-system (make-instance 'hssg:overlay-file-system
|
||||||
|
:directory #p"blog"
|
||||||
|
:parent (make-instance 'hssg:base-file-system
|
||||||
|
:directory #p"output")))
|
||||||
|
(instruction (make-instance 'hssg:write-string-contents
|
||||||
|
:path #p"css/main.css"
|
||||||
|
:contents "Hello world")))
|
||||||
|
(with-mock ((hssg.filesystem::write-string-to-file
|
||||||
|
(lambda (contents path)
|
||||||
|
(incf counter)
|
||||||
|
(assert-equal "Hello world" contents)
|
||||||
|
(assert-equal #p"output/blog/css/main.css" path))))
|
||||||
|
(hssg:write-to-filesystem instruction file-system)
|
||||||
|
(assert-eql 1 counter))))
|
||||||
|
|
||||||
|
(deftest write/copy-directory/base-filesystem (hssg.filesystem.write)
|
||||||
|
"Copying a directory recursively to a base file system copies the entire directory"
|
||||||
|
(let ((file-system (make-instance 'hssg:base-file-system :directory #p"output"))
|
||||||
|
(instruction (make-instance 'hssg:copy-directory :path #p"assets/images" :base-path #p"content"))
|
||||||
|
(counter 0))
|
||||||
|
(with-mock ((hssg.filesystem::copy-directory
|
||||||
|
(lambda (original copy)
|
||||||
|
(incf counter)
|
||||||
|
(assert-equal #p"content/assets/images/" original)
|
||||||
|
(assert-equal #p"output/assets/images/" copy)
|
||||||
|
nil)))
|
||||||
|
(hssg:write-to-filesystem instruction file-system)
|
||||||
|
(assert-eql 1 counter))))
|
||||||
|
|
||||||
|
(deftest write/compound-instruction/base-filesystem (hssg.filesystem.write)
|
||||||
|
"Writing a compound instruction writes all its children in order."
|
||||||
|
(let* ((file-system (make-instance 'dummy-filesystem))
|
||||||
|
(written (list))
|
||||||
|
(dummy1 (make-instance 'dummy-instruction
|
||||||
|
:on-write (lambda (self) (push self written))))
|
||||||
|
(dummy2 (make-instance 'dummy-instruction
|
||||||
|
:on-write (lambda (self) (push self written))))
|
||||||
|
(instruction (make-instance 'hssg:compound-instruction
|
||||||
|
:instructions (list dummy1 dummy2))))
|
||||||
|
(hssg:write-to-filesystem instruction file-system)
|
||||||
|
(assert-eql 2 (length written))
|
||||||
|
(loop for instruction in written
|
||||||
|
for dummy in (list dummy2 dummy1) ; Reverse order because of push!
|
||||||
|
do (assert-true (eq dummy instruction)))))
|
||||||
56
test/mocking.lisp
Normal file
56
test/mocking.lisp
Normal file
|
|
@ -0,0 +1,56 @@
|
||||||
|
;;;; SPDX-License-Identifier AGPL-3.0-or-later
|
||||||
|
|
||||||
|
;;;; mocking.lisp A minimal function mocking framework
|
||||||
|
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
|
||||||
|
;;;;
|
||||||
|
;;;; This file is part of CL-HSSG.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is free software: you can redistribute it and/or modify it under
|
||||||
|
;;;; the terms of the GNU Affero General Public License as published by the
|
||||||
|
;;;; Free Software Foundation, either version 3 of the License, or (at your
|
||||||
|
;;;; option) any later version.
|
||||||
|
;;;;
|
||||||
|
;;;; CL-HSSG is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
|
;;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||||||
|
;;;; FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
|
||||||
|
;;;; more details.
|
||||||
|
;;;;
|
||||||
|
;;;; You should have received a copy of the GNU Affero General Public License
|
||||||
|
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.(in-package #:hssg.artifact)
|
||||||
|
(defpackage #:hssg/test-mocking
|
||||||
|
(:documentation "A minimal function mocking framework.")
|
||||||
|
(:use #:cl)
|
||||||
|
(:export #:with-mock))
|
||||||
|
(in-package #:hssg/test-mocking)
|
||||||
|
|
||||||
|
|
||||||
|
(defun mock-to-save (original-name temp-name)
|
||||||
|
`(,temp-name (symbol-function ',original-name)))
|
||||||
|
|
||||||
|
(defun mock-to-restore (original-name temp-name)
|
||||||
|
`(setf (symbol-function ',original-name) ,temp-name))
|
||||||
|
|
||||||
|
(defun mock-to-injection (original-name temp-value)
|
||||||
|
`(setf (symbol-function ',original-name) ,temp-value))
|
||||||
|
|
||||||
|
|
||||||
|
(defmacro with-mock ((&rest mocks) &body body)
|
||||||
|
"Temporarily rebind symbol functions for the given symbols. Outside the form
|
||||||
|
the original bindings will be restored. This is useful to mock functions with
|
||||||
|
side effects during testing. Inside the mock body we can place our assertions
|
||||||
|
to e.g. test that the correct arguments were passed. Example:
|
||||||
|
|
||||||
|
;;; Hard-coded default values for the mocked functions
|
||||||
|
(with-mocks ((foo (lambda (x y) T))
|
||||||
|
(bar (lambda (x y) T)))
|
||||||
|
(assert (foo 1 2))
|
||||||
|
(assert (bar 3 4)))"
|
||||||
|
(let ((temp-names (loop for mock in mocks collect (gensym)))
|
||||||
|
(temp-values (mapcar #'cadr mocks))
|
||||||
|
(original-names (mapcar #'car mocks)))
|
||||||
|
`(let ,(mapcar #'mock-to-save original-names temp-names)
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
,@(mapcar #'mock-to-injection original-names temp-values)
|
||||||
|
,@body)
|
||||||
|
,@(mapcar #'mock-to-restore original-names temp-names)))))
|
||||||
Loading…
Add table
Reference in a new issue