From 0aa9d4fd692040949e9948bce09ebf11f3e50a65 Mon Sep 17 00:00:00 2001 From: HiPhish Date: Mon, 31 Oct 2022 15:23:26 +0100 Subject: [PATCH] Implement file systems and instructions in core --- TODO.rst | 32 +++++ hssg.asd | 11 +- src/hssg/artifact.lisp | 10 ++ src/hssg/artifacts/classes.lisp | 16 +-- src/hssg/artifacts/compound.lisp | 5 + src/hssg/artifacts/directory.lisp | 19 +-- src/hssg/artifacts/html.lisp | 36 ++++-- src/hssg/artifacts/verbatim.lisp | 18 ++- src/hssg/artifacts/xml.lisp | 8 ++ src/hssg/filesystem.lisp | 193 +++++++++++++++++++++++++++++ src/hssg/package.lisp | 26 +++- test/hssg/artifacts/compound.lisp | 108 +++++++++++----- test/hssg/artifacts/directory.lisp | 38 ++++++ test/hssg/artifacts/html.lisp | 52 ++++++++ test/hssg/artifacts/verbatim.lisp | 51 ++++++++ test/hssg/artifacts/xml.lisp | 41 ++++++ test/hssg/file-system.lisp | 162 ++++++++++++++++++++++++ test/mocking.lisp | 56 +++++++++ 18 files changed, 812 insertions(+), 70 deletions(-) create mode 100644 src/hssg/filesystem.lisp create mode 100644 test/hssg/artifacts/directory.lisp create mode 100644 test/hssg/artifacts/html.lisp create mode 100644 test/hssg/artifacts/verbatim.lisp create mode 100644 test/hssg/artifacts/xml.lisp create mode 100644 test/hssg/file-system.lisp create mode 100644 test/mocking.lisp diff --git a/TODO.rst b/TODO.rst index 241084e..c98d2eb 100644 --- a/TODO.rst +++ b/TODO.rst @@ -8,6 +8,36 @@ 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 ==================== @@ -35,6 +65,8 @@ Cleanup - A proper public interface to the various artifact classes - Expose reader interface to public +- Remove `WRITE-ARTIFACT` generic function and its methods once file system and + instructions are implemented everywhere Testing ======= diff --git a/hssg.asd b/hssg.asd index b55eb8f..21d1925 100644 --- a/hssg.asd +++ b/hssg.asd @@ -29,6 +29,7 @@ :components ((:module "hssg" :components ((:file "package") (:file "config") + (:file "filesystem") (:file "reader") (:module "readers" :components ((:file "lisp"))) @@ -53,12 +54,18 @@ :perform (test-op (o s) (symbol-call :hssg/test :test-all)) :components ((:module "test" - :components ((:module "hssg" + :components ((:file "mocking") + (:module "hssg" :components ((:file "package") (:file "main") + (:file "file-system") (:file "template") (:file "reader") (:module "readers" :components ((:file "lisp"))) (:module "artifacts" - :components ((:file "compound"))))))))) + :components ((:file "compound") + (:file "directory") + (:file "html") + (:file "verbatim") + (:file "xml"))))))))) diff --git a/src/hssg/artifact.lisp b/src/hssg/artifact.lisp index 8db30b0..5db10eb 100644 --- a/src/hssg/artifact.lisp +++ b/src/hssg/artifact.lisp @@ -22,3 +22,13 @@ (defgeneric write-artifact (artifact) (:documentation "Write the given ARTIFACT to disc. The artifact's state 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))) diff --git a/src/hssg/artifacts/classes.lisp b/src/hssg/artifacts/classes.lisp index 84f5b65..ec5d28c 100644 --- a/src/hssg/artifacts/classes.lisp +++ b/src/hssg/artifacts/classes.lisp @@ -20,17 +20,17 @@ (in-package #:hssg.artifact) (defclass verbatim-artifact () - ((input :reader verbatim-artifact-input :initarg :input :type pathname - :documentation "Path to the file to copy") - (output :initarg :output :type pathname - :documentation "Path where to write the produced artifact.")) + ((file-name :initarg :file :type pathname + :documentation "Original file name") + (directory :initarg :directory :type pathname + :documentation "Base path to the file to copy, will not be copied")) (:documentation "Artifact which copies one filed to another location")) (defclass directory-artifact () - ((input :reader directory-artifact-input :initarg :input :type pathname - :documentation "Path to the directory to copy recursively") - (output :initarg :output :type pathname - :documentation "Path where to write the produced artifact.")) + ((directory :initarg :directory :type pathname + :documentation "Original directory path, relative to base directory") + (base :initarg :base :type pathname + :documentation "Base path to the directory, will not be copied")) (:documentation "Artifact which copies a directory and its contents recursively to another location")) (defclass compound-artifact () diff --git a/src/hssg/artifacts/compound.lisp b/src/hssg/artifacts/compound.lisp index e16fc68..0480b13 100644 --- a/src/hssg/artifacts/compound.lisp +++ b/src/hssg/artifacts/compound.lisp @@ -24,6 +24,11 @@ (dolist (artifact (slot-value wrapper 'hssg.artifact:artifacts)) (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) "Create a new compound artifact, which is a wrapper around the given ARTIFACTS. Writing a compound artifact writes all the wrapped artifact in the diff --git a/src/hssg/artifacts/directory.lisp b/src/hssg/artifacts/directory.lisp index c11c933..cb872cd 100644 --- a/src/hssg/artifacts/directory.lisp +++ b/src/hssg/artifacts/directory.lisp @@ -36,13 +36,18 @@ (fad:copy-file pathname target :overwrite t)))))) 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 directory FILE-PATH and its contents recursively from INPUT-DIR to OUTPUT-DIR." - (declare (type (or string pathname) file-path input-dir output-dir)) - (let ((input (merge-pathnames file-path (fad:pathname-as-directory input-dir))) - (output (merge-pathnames file-path (fad:pathname-as-directory output-dir)))) - (make-instance 'hssg.artifact:directory-artifact - :input (fad:pathname-as-directory input) - :output (fad:pathname-as-directory output)))) + (declare (type (or string pathname) base directory)) + (make-instance 'hssg.artifact:directory-artifact + :base base :directory directory)) diff --git a/src/hssg/artifacts/html.lisp b/src/hssg/artifacts/html.lisp index 328c827..6859fd9 100644 --- a/src/hssg/artifacts/html.lisp +++ b/src/hssg/artifacts/html.lisp @@ -19,6 +19,30 @@ ;;;; along with CL-HSSG If not, see . (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 "~%") + (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 "~%~A" contents) + :path output)))) + (defun read-html-lisp (fpath output &optional &key (template #'identity) (initial nil)) "Read the contents of an HTML document from a Lisp file." (declare (type (or string pathname) fpath output)) @@ -76,18 +100,6 @@ (loop for child in tail when child do (sexp->plump-tree child 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 "~%") - (plump:serialize (sexp->plump-tree - (cdr (assoc :content (funcall template data))))))))) - (defmacro static-page ((&rest bindings) &body content) "Static page DSL macro diff --git a/src/hssg/artifacts/verbatim.lisp b/src/hssg/artifacts/verbatim.lisp index 60ab508..b66d7d5 100644 --- a/src/hssg/artifacts/verbatim.lisp +++ b/src/hssg/artifacts/verbatim.lisp @@ -19,7 +19,7 @@ ;;;; along with CL-HSSG If not, see . (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. (defparameter *buffer-size* 512 "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) 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 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)) - (let* ((input (merge-pathnames file-path (fad:pathname-as-directory input-dir))) - (output (merge-pathnames file-path (fad:pathname-as-directory output-dir)))) - (make-instance 'hssg.artifact:verbatim-artifact :input input :output output))) + (declare (type (or string pathname) base-dir file-name)) + (make-instance 'hssg.artifact:verbatim-artifact :directory base-dir :file file-name)) diff --git a/src/hssg/artifacts/xml.lisp b/src/hssg/artifacts/xml.lisp index b946521..e1de02c 100644 --- a/src/hssg/artifacts/xml.lisp +++ b/src/hssg/artifacts/xml.lisp @@ -26,6 +26,14 @@ (with-open-file (*STANDARD-OUTPUT* output :direction :output :if-exists :supersede :if-does-not-exist :create) (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")) "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 diff --git a/src/hssg/filesystem.lisp b/src/hssg/filesystem.lisp new file mode 100644 index 0000000..cbb9784 --- /dev/null +++ b/src/hssg/filesystem.lisp @@ -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 .(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)))) diff --git a/src/hssg/package.lisp b/src/hssg/package.lisp index b921ef2..bb2e143 100644 --- a/src/hssg/package.lisp +++ b/src/hssg/package.lisp @@ -18,6 +18,17 @@ ;;;; You should have received a copy of the GNU Affero General Public License ;;;; along with CL-HSSG If not, see . +;;; --------------------------------------------------------------------------- +(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 (:documentation "Interface to the various content readers.") (:use :cl) @@ -26,9 +37,12 @@ (defpackage #:hssg.artifact (:documentation "Helper package, defines the artifact protocl.") (: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)) + ;;; --------------------------------------------------------------------------- (defpackage #:hssg.artifact._compound (:documentation "Implementatio of compound HSSG artifacts.") @@ -64,6 +78,11 @@ (defpackage #:hssg (:documentation "The hackable static site generator") (: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._compound make-compound-artifact compound-artifact-push) (:import-from #:hssg.artifact.directory make-directory-artifact) @@ -73,6 +92,11 @@ chain-templates template-with-data) (:export *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 write-artifact ;; Compound artifacts diff --git a/test/hssg/artifacts/compound.lisp b/test/hssg/artifacts/compound.lisp index 48ca8ae..0fac03f 100644 --- a/test/hssg/artifacts/compound.lisp +++ b/test/hssg/artifacts/compound.lisp @@ -16,53 +16,93 @@ ;;;; more details. ;;;; ;;;; You should have received a copy of the GNU Affero General Public License -;;;; along with CL-HSSG If not, see .(in-package #:hssg.artifact) +;;;; along with CL-HSSG If not, see (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) -;;; "Compound artifact implementation tests") +;;; Compound artifact implementation tests (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)) -;;; --------------------------------------------------------------------------- -(defstruct counter - "A mutable counter to keep track of how often the dummy artifact has been - written." - (count 0)) - +;;; --- FAKES ----------------------------------------------------------------- (defclass dummy-artifact () - ((counter :initarg :counter :accessor dummy-counter - :documentation "A (possibly shared) counter instance")) - (:documentation "A fake artifact which increments its counter")) + () + (:documentation "A fake artifact")) -(defmethod hssg:write-artifact ((dummy dummy-artifact)) - (incf (counter-count (dummy-counter dummy))) - :ok) +(defclass dummy-instruction () + ((artifact :initarg :artifact :reader dummy-artifact)) + (:documentation "A fake instruction")) -(clunit:deffixture hssg.artifact.compound (@body) - (let ((counter (make-counter))) - @body)) +(defmethod hssg.artifact:derive-artifact ((artifact dummy-artifact)) + "Attach the artifact to the instruction so we can check it was called." + (make-instance 'dummy-instruction :artifact artifact)) -(clunit:deftest create-and-write (hssg.artifact.compound) - "Writing a compound artifacts writes all all of its artifacts" - (let ((artifact (hssg:make-compound-artifact - (make-instance 'dummy-artifact :counter counter) - (make-instance 'dummy-artifact :counter counter) - (make-instance 'dummy-artifact :counter counter)))) - (hssg:write-artifact artifact)) - (let ((count (counter-count counter))) - (clunit:assert-eql 3 count count))) +;;; --- CONSTRUCTOR ----------------------------------------------------------- +(deftest make-empty (hssg.artifact.compound.constructor) + "An empty artifact has no children." + (let ((compound (hssg:make-compound-artifact))) + (with-slots ((artifacts hssg.artifact:artifacts)) + compound + (clunit:assert-false artifacts)))) -(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" (let ((compound (hssg:make-compound-artifact)) - (dummy1 (make-instance 'dummy-artifact :counter counter)) - (dummy2 (make-instance 'dummy-artifact :counter counter))) - (hssg:compound-artifact-push compound dummy1) + (dummy1 (make-instance 'dummy-artifact)) + (dummy2 (make-instance 'dummy-artifact))) (hssg:compound-artifact-push compound dummy2) - (hssg:write-artifact compound)) - (clunit:assert-eql 2 (counter-count counter))) + (hssg:compound-artifact-push compound dummy1) + (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))))))) diff --git a/test/hssg/artifacts/directory.lisp b/test/hssg/artifacts/directory.lisp new file mode 100644 index 0000000..c3e5827 --- /dev/null +++ b/test/hssg/artifacts/directory.lisp @@ -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 +(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)))) diff --git a/test/hssg/artifacts/html.lisp b/test/hssg/artifacts/html.lisp new file mode 100644 index 0000000..465a1b1 --- /dev/null +++ b/test/hssg/artifacts/html.lisp @@ -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 +(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 " +

Hello world!

" + contents) + (assert-equal #p"blog/index.html" path)))) diff --git a/test/hssg/artifacts/verbatim.lisp b/test/hssg/artifacts/verbatim.lisp new file mode 100644 index 0000000..20ea579 --- /dev/null +++ b/test/hssg/artifacts/verbatim.lisp @@ -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 +(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)))) diff --git a/test/hssg/artifacts/xml.lisp b/test/hssg/artifacts/xml.lisp new file mode 100644 index 0000000..e87b364 --- /dev/null +++ b/test/hssg/artifacts/xml.lisp @@ -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 +(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 "" contents) + (assert-equal #p"blog/rss.xml" path)))) diff --git a/test/hssg/file-system.lisp b/test/hssg/file-system.lisp new file mode 100644 index 0000000..d53c894 --- /dev/null +++ b/test/hssg/file-system.lisp @@ -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 +(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))))) diff --git a/test/mocking.lisp b/test/mocking.lisp new file mode 100644 index 0000000..ee7453b --- /dev/null +++ b/test/mocking.lisp @@ -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 .(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)))))