marcuskammer/cl-hssg
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement file systems and instructions in blog

Browse source
This commit is contained in:
HiPhish 2022-11-05 13:09:32 +01:00
parent 0aa9d4fd69
commit d475072b84
31 changed files with 508 additions and 235 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
hssg-blog.asd
View file

@ -25,7 +25,7 @@
:version "0.0.0" :version "0.0.0"
:depends-on ("hssg" "cmark" "cl-fad") :depends-on ("hssg" "cmark" "cl-fad")
:serial t :serial t
:components ((module "src" :components ((:module "src"
:components ((:module "blog" :components ((:module "blog"
:components ((:file "package") :components ((:file "package")
(:file "config") (:file "config")
@ -54,4 +54,21 @@
(:file "index") (:file "index")
(:file "post"))) (:file "post")))
(:file "templates") (:file "templates")
(:file "facade"))))))) (:file "facade"))))))
:in-order-to ((test-op (test-op "hssg-blog/test"))))
(asdf:defsystem #:hssg-blog/test
:description "Tests for HSSG-BLOG"
:author "HiPhish <hiphish@posteo.de>"
:license "AGPL-3.0-or-later"
:version "0.0.0"
:depends-on ("hssg-blog" "clunit2")
:serial t
:perform (test-op (o s)
(symbol-call :hssg-blog/test :test-all))
:components ((:module "test"
:components ((:file "mocking")
(:module "blog"
:components ((:file "main")
(:module "artifacts"
:components ((:file "archive")))))))) )

4
hssg.asd
View file

@ -23,7 +23,7 @@
:author "HiPhish <hiphish@posteo.de>" :author "HiPhish <hiphish@posteo.de>"
:license "AGPL-3.0-or-later" :license "AGPL-3.0-or-later"
:version "0.0.0" :version "0.0.0"
:depends-on ("alexandria" "cl-fad" "local-time" "plump") :depends-on ("alexandria" "cl-fad" "uiop" "local-time" "plump")
:serial t :serial t
:components ((:module "src" :components ((:module "src"
:components ((:module "hssg" :components ((:module "hssg"
@ -49,7 +49,7 @@
:author "HiPhish <hiphish@posteo.de>" :author "HiPhish <hiphish@posteo.de>"
:license "AGPL-3.0-or-later" :license "AGPL-3.0-or-later"
:version "0.0.0" :version "0.0.0"
:depends-on ("hssg" "clunit2") :depends-on ("hssg" "clunit2" "uiop")
:serial t :serial t
:perform (test-op (o s) :perform (test-op (o s)
(symbol-call :hssg/test :test-all)) (symbol-call :hssg/test :test-all))

31
src/blog/artifacts/archive.lisp
View file

@ -20,12 +20,34 @@
;;;; 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.blog.artifact.archive) (in-package #:hssg.blog.artifact.archive)
(defmethod hssg:write-artifact ((archive archive-page-artifact)) (defun archive->html (archive)
"Transforms a given archive page artifact to an HTML page artifact."
(with-slots ((periods hssg.blog.artifacts:periods) (with-slots ((periods hssg.blog.artifacts:periods)
(blog hssg.blog.artifacts:blog)) (blog hssg.blog.artifacts:blog))
archive archive
(with-slots ((url hssg.blog.artifacts:url) (with-slots ((url hssg.blog.artifacts:url)
(output hssg.blog.artifacts:output) ; (output hssg.blog.artifacts:output)
(template hssg.blog.artifacts:template)
(initial hssg.blog.artifacts:initial))
blog
(let ((data `((:periods . ,periods) (:blog . ,blog) ,@initial))
(template (hssg:chain-templates
'hssg.blog.template:archive 'hssg.blog.template:blog-page template))
(output (apply #'fad:merge-pathnames-as-file
`(;,output
,(fad:pathname-as-directory "archive")
,(fad:pathname-as-file "index.html")))))
(make-instance 'hssg:html-artifact
:data data
:template template
:output output)))))
(defmethod hssg:derive-artifact ((artifact archive-page-artifact))
(with-slots ((periods hssg.blog.artifacts:periods)
(blog hssg.blog.artifacts:blog))
artifact
(with-slots ((url hssg.blog.artifacts:url)
; (output hssg.blog.artifacts:output)
(template hssg.blog.artifacts:template) (template hssg.blog.artifacts:template)
(initial hssg.blog.artifacts:initial)) (initial hssg.blog.artifacts:initial))
blog blog
@ -38,7 +60,6 @@
'hssg.blog.template:blog-page 'hssg.blog.template:blog-page
template) template)
:output (apply #'fad:merge-pathnames-as-file :output (apply #'fad:merge-pathnames-as-file
`(,output `(,(fad:pathname-as-directory "archive")
,(fad:pathname-as-directory "archive")
,(fad:pathname-as-file "index.html")))))) ,(fad:pathname-as-file "index.html"))))))
(hssg:write-artifact html-page))))) (hssg:derive-artifact html-page)))))

82
src/blog/artifacts/blog.lisp
View file

@ -19,43 +19,53 @@
;;;; 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.blog.artifacts.blog) (in-package #:hssg.blog.artifacts.blog)
(defmethod hssg:write-artifact ((blog blog-artifact)) (defun derive-month-period (month-period year blog)
(with-slots (posts categories tags periods output static) blog (with-slots ((month hssg.blog.period:month))
month-period
(let ((artifact (make-instance 'hssg.blog.artifacts:index-page-artifact
:url (list (format nil "~D" year)
(format nil "~2,'0D" month))
:posts (hssg.blog.period:period-posts month-period)
:number 1
:total 1
:blog blog)))
(hssg:derive-artifact artifact))))
(defun derive-year-period (year-period blog)
(with-slots ((year hssg.blog.period:year)
(months hssg.blog.period:months))
year-period
(let ((year-artifact (make-instance 'hssg.blog.artifacts:index-page-artifact
:url (list (format nil "~D" year))
:posts (hssg.blog.period:period-posts year-period)
:number 1
:total 1
:blog blog)))
(make-instance 'hssg:compound-instruction
:instructions (list (hssg:derive-artifact year-artifact)
(make-instance 'hssg:compound-instruction
:instructions (mapcar
(lambda (month) (derive-month-period month year blog))
months)))))))
(defmethod hssg:derive-artifact ((blog blog-artifact))
(with-slots (posts categories tags periods static) blog
(with-slots (items) categories (with-slots (items) categories
(setf items (sort items #'string<= :key #'hssg.blog.artifacts:category-name))) (setf items (sort items #'string<= :key #'hssg.blog.artifacts:category-name)))
(with-slots (items) tags (with-slots (items) tags
(setf items (sort items #'>= :key (lambda (tag) (length (slot-value tag 'hssg.blog.artifacts:posts)))))) (setf items (sort items #'>= :key (lambda (tag) (length (slot-value tag 'hssg.blog.artifacts:posts))))))
(dolist (post posts)
(write-artifact post)) (let ((artifacts (list
(dolist (index-page (hssg.blog.artifact.util:collect-index-pages posts blog '())) static
(write-artifact index-page)) categories
(dolist (year-period periods) tags
(with-slots ((year hssg.blog.period:year) (make-instance 'hssg.blog.artifacts:archive-page-artifact :periods periods :blog blog)
(months hssg.blog.period:months)) (make-instance 'hssg.blog.artifacts:rss-feed-artifact :posts posts :blog blog))))
year-period (make-instance 'hssg:compound-instruction
(let ((artifact (make-instance 'hssg.blog.artifacts:index-page-artifact :instructions
:url (list (format nil "~D" year)) (concatenate
:posts (hssg.blog.period:period-posts year-period) 'list
:number 1 (mapcar (lambda (year-period) (derive-year-period year-period blog)) periods)
:total 1 (mapcar #'hssg:derive-artifact posts)
:prev nil (mapcar #'hssg:derive-artifact (hssg.blog.artifact.util:collect-index-pages posts blog '()))
:next nil (mapcar #'hssg:derive-artifact artifacts))))))
:blog blog)))
(write-artifact artifact))
(dolist (month-period (slot-value year-period 'hssg.blog.period:months))
(with-slots ((month hssg.blog.period:month)) month-period
(let ((artifact (make-instance 'hssg.blog.artifacts:index-page-artifact
:url (list (format nil "~D" year)
(format nil "~2,'0D" month))
:posts (hssg.blog.period:period-posts month-period)
:number 1
:total 1
:prev nil
:next nil
:blog blog)))
(write-artifact artifact))))))
(write-artifact static)
(write-artifact categories)
(write-artifact tags)
(write-artifact (make-instance 'hssg.blog.artifacts:archive-page-artifact :periods periods :blog blog))
(write-artifact (make-instance 'hssg.blog.artifacts:rss-feed-artifact :posts posts :blog blog))))

70
src/blog/artifacts/category.lisp
View file

@ -19,35 +19,6 @@
;;;; 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.blog.artifact.category) (in-package #:hssg.blog.artifact.category)
(defmethod hssg:write-artifact ((category category-artifact))
(with-slots ((blog hssg.blog.artifacts:blog)
(name hssg.blog.artifacts:name)
(posts hssg.blog.artifacts:posts))
category
(dolist (index-page (hssg.blog.artifact.util:collect-index-pages
posts blog (list (hssg.blog.i18n:localise :url-categories) name)))
(hssg:write-artifact index-page))))
(defmethod hssg:write-artifact ((artifact categories-artifact))
(with-slots ((items hssg.blog.artifacts:items)
(blog hssg.blog.artifacts:blog))
artifact
(let ((artifact (make-instance 'hssg:html-artifact
:data `((:categories . ,items)
(:blog . ,blog)
,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates
'hssg.blog.template:categories
'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template))
:output (fad:merge-pathnames-as-file
(slot-value blog 'hssg.blog.artifacts:output)
(fad:pathname-as-directory (hssg.blog.i18n:localise :url-categories))
(fad:pathname-as-file "index.html")))))
(hssg:write-artifact artifact))
(dolist (category items)
(hssg:write-artifact category))))
(defun fetch-category (categories name) (defun fetch-category (categories name)
"Retrieve the category object with a given NAME from a BLOG artifact; if "Retrieve the category object with a given NAME from a BLOG artifact; if
there is no category object it is created and registered first." there is no category object it is created and registered first."
@ -62,6 +33,47 @@
result)))) result))))
(defun add-post (categories name post) (defun add-post (categories name post)
"Adds a single POST to the CATEGORIES collection under the key NAME."
(with-slots ((posts hssg.blog.artifacts:posts)) (with-slots ((posts hssg.blog.artifacts:posts))
(fetch-category categories name) (fetch-category categories name)
(push post posts))) (push post posts)))
(defun categories->html (items blog)
"Reduce them ITEMS of a CATEGORIES-ARTIFACT instance to an HTML page
artifact."
(make-instance 'hssg:html-artifact
:data `((:categories . ,items)
(:blog . ,blog)
,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates
'hssg.blog.template:categories
'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template))
:output (fad:merge-pathnames-as-file
(fad:pathname-as-directory
(hssg.blog.i18n:localise :url-categories))
(fad:pathname-as-file "index.html"))))
(defmethod hssg:derive-artifact ((category category-artifact))
"Compound instruction, one instruction per index page."
(with-slots ((blog hssg.blog.artifacts:blog)
(name hssg.blog.artifacts:name)
(posts hssg.blog.artifacts:posts))
category
(make-instance 'hssg:compound-instruction
:instructions (mapcar
#'hssg:derive-artifact
(hssg.blog.artifact.util:collect-index-pages
posts blog (list (hssg.blog.i18n:localise :url-categories) name))))))
(defmethod hssg:derive-artifact ((artifact categories-artifact))
"Compound instruction: one instructions for the whole categories page and one
instruction per individual category (which itself is a compound instruction)."
(with-slots ((items hssg.blog.artifacts:items)
(blog hssg.blog.artifacts:blog))
artifact
(let ((categories-page (hssg:derive-artifact (categories->html items blog)))
(category-indeces (mapcar #'hssg:derive-artifact items)))
(make-instance 'hssg:compound-instruction
:instructions (cons categories-page category-indeces)))))

10
src/blog/artifacts/classes.lisp
View file

@ -27,7 +27,7 @@
:documentation "Human-readable title of the blog.") :documentation "Human-readable title of the blog.")
(description :initarg :description :initform "" :type string (description :initarg :description :initform "" :type string
:documentation "Human-readable description of the blog") :documentation "Human-readable description of the blog")
(posts :initform '() :type list (posts :initform (list) :type list
:documentation "List of blog posts ordered from most recent to oldest.") :documentation "List of blog posts ordered from most recent to oldest.")
(categories :initform (make-instance 'categories-artifact) :type categories-artifact (categories :initform (make-instance 'categories-artifact) :type categories-artifact
:documentation "Collection of categories of the blog") :documentation "Collection of categories of the blog")
@ -35,15 +35,13 @@
:documentation "Collection of tags of the blog") :documentation "Collection of tags of the blog")
(authors :initform (make-hash-table :test 'equal) :type hash-table (authors :initform (make-hash-table :test 'equal) :type hash-table
:documentation "Maps an author's name to an unordered set of posts.") :documentation "Maps an author's name to an unordered set of posts.")
(periods :initform '() :type list (periods :initform (list) :type list
:documentation "Year periods of the blog.") :documentation "Year periods of the blog.")
(top :initarg :top :initform "" :type string (top :initarg :top :initform "" :type string
:documentation "Identifier to use as the top of the breadcrumbs") :documentation "Identifier to use as the top of the breadcrumbs")
(url :initarg :url :type list (url :initarg :url :type list
:documentation "URL of the blog as a list of URL path strings, relative :documentation "URL of the blog as a list of URL path strings, relative
to the root of the site.") to the root of the site.")
(output :initarg :output :type pathname
:documentation "Path to the blog, relative to the root of the site")
(template :initarg :template :initform #'hssg:identity-template :type hssg:template (template :initarg :template :initform #'hssg:identity-template :type hssg:template
:documentation "Base template to apply to all pages") :documentation "Base template to apply to all pages")
(initial :initarg :initial :initform '() :type list (initial :initarg :initial :initform '() :type list
@ -121,9 +119,9 @@
:documentation "Number of this page among all pages") :documentation "Number of this page among all pages")
(total :initform 1 :initarg :total :type (integer 1) (total :initform 1 :initarg :total :type (integer 1)
:documentation "How many pages there are in total.") :documentation "How many pages there are in total.")
(previous :initarg :prev :type (or null index-page-artifact) (previous :initarg :prev :initform nil :type (or null index-page-artifact)
:documentation "Previous page, if any") :documentation "Previous page, if any")
(next :initarg :next :type (or null index-page-artifact) (next :initarg :next :initform nil :type (or null index-page-artifact)
:documentation "Next page, if any") :documentation "Next page, if any")
(blog :initarg :blog :type blog-artifact (blog :initarg :blog :type blog-artifact
:documentation "The blog instance this index belongs to.")) :documentation "The blog instance this index belongs to."))

54
src/blog/artifacts/index-page.lisp
View file

@ -19,31 +19,6 @@
;;;; 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.blog.artifact.index-page) (in-package #:hssg.blog.artifact.index-page)
(defmethod hssg:write-artifact ((page index-page-artifact))
(with-slots ((url hssg.blog.artifacts:url)
(blog hssg.blog.artifacts:blog)
(number hssg.blog.artifacts:number)
(total hssg.blog.artifacts:total)
(posts hssg.blog.artifacts:posts))
page
(let ((artifact (make-instance 'hssg:html-artifact
:data `((:page . ,number)
(:pages . ,total)
(:blog . ,blog)
(:posts . ,posts)
(:breadcrumbs . ,(url-to-breadcrumbs url))
,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates
'hssg.blog.template:article-index
'hssg.blog.template:index
'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template))
:output (apply #'fad:merge-pathnames-as-file
`(,(slot-value blog 'hssg.blog.artifacts:output)
,@(mapcar #'fad:pathname-as-directory url)
,(fad:pathname-as-file "index.html"))))))
(hssg:write-artifact artifact))))
(defun url-to-breadcrumbs (url) (defun url-to-breadcrumbs (url)
"Converts a URL (list of strings) to breadcrums (list of a-lists)." "Converts a URL (list of strings) to breadcrums (list of a-lists)."
(maplist (lambda (items) (maplist (lambda (items)
@ -53,3 +28,32 @@
`((:title . ,(car items)) `((:title . ,(car items))
(:url . ,(format nil "~V@{~A/~:*~}" level "..")))))) (:url . ,(format nil "~V@{~A/~:*~}" level ".."))))))
url)) url))
(defun page->html (page)
"Transforms a blog index page artifact to an HTML page artifact."
(with-slots ((url hssg.blog.artifacts:url)
(blog hssg.blog.artifacts:blog)
(number hssg.blog.artifacts:number)
(total hssg.blog.artifacts:total)
(posts hssg.blog.artifacts:posts))
page
(make-instance 'hssg:html-artifact
:data `((:page . ,number)
(:pages . ,total)
(:blog . ,blog)
(:posts . ,posts)
(:breadcrumbs . ,(url-to-breadcrumbs url))
,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates
'hssg.blog.template:article-index
'hssg.blog.template:index
'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template))
:output (apply #'fad:merge-pathnames-as-file
`(,@(mapcar #'fad:pathname-as-directory url)
,(fad:pathname-as-file "index.html"))))))
(defmethod hssg:derive-artifact ((page index-page-artifact))
(let ((html-page (page->html page)))
(hssg:derive-artifact html-page)))

55
src/blog/artifacts/post.lisp
View file

@ -19,7 +19,9 @@
;;;; 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.blog.artifact.post) (in-package #:hssg.blog.artifact.post)
(defmethod hssg:write-artifact ((post post-artifact)) (defun post->html (post)
"Transforms one blog post to an HTML page artifact."
(declare (type post-artifact post))
(with-slots ((blog hssg.blog.artifacts:blog) (with-slots ((blog hssg.blog.artifacts:blog)
(slug hssg.blog.artifacts:slug) (slug hssg.blog.artifacts:slug)
(title hssg.blog.artifacts:title) (title hssg.blog.artifacts:title)
@ -34,29 +36,30 @@
(next hssg.blog.artifacts:next) (next hssg.blog.artifacts:next)
(metadata hssg.blog.artifacts:metadata)) (metadata hssg.blog.artifacts:metadata))
post post
(let ((artifact (make-instance 'hssg.artifact:html-artifact (make-instance 'hssg.artifact:html-artifact
:data `((:blog . ,blog) :data `((:blog . ,blog)
(:post . ((:slug . ,slug) (:post . ((:slug . ,slug)
(:title . ,title) (:title . ,title)
(:content . ,content) (:content . ,content)
(:category . ,category) (:category . ,category)
(:tags . ,tags) (:tags . ,tags)
(:author . ,author) (:author . ,author)
(:published . ,published) (:published . ,published)
(:modified . ,modified) (:modified . ,modified)
(:status . ,status) (:status . ,status)
,@metadata)) ,@metadata))
(:prev . ,previous) (:prev . ,previous)
(:next . ,next) (:next . ,next)
,@(slot-value blog 'hssg.blog.artifacts:initial)) ,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates :template (hssg:chain-templates
'hssg.blog.template:post 'hssg.blog.template:post
'hssg.blog.template:blog-page 'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template)) (slot-value blog 'hssg.blog.artifacts:template))
:output (fad:merge-pathnames-as-file :output (fad:merge-pathnames-as-file
(slot-value blog 'hssg.blog.artifacts:output) (hssg.blog.util:date->pathname published)
(hssg.blog.util:date->pathname published) (fad:pathname-as-directory slug)
(fad:pathname-as-directory slug) (fad:pathname-as-file "index.html")))))
(fad:pathname-as-file "index.html")))))
(hssg:write-artifact artifact))))
(defmethod hssg:derive-artifact ((post post-artifact))
(let ((html-page (post->html post)))
(hssg:derive-artifact html-page)))

60
src/blog/artifacts/rss-feed.lisp
View file

@ -19,35 +19,6 @@
;;;; 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.blog.artifact.rss-feed) (in-package #:hssg.blog.artifact.rss-feed)
(defmethod hssg:write-artifact ((rss-feed rss-feed-artifact))
(with-slots ((posts hssg.blog.artifacts:posts)
(blog hssg.blog.artifacts:blog))
rss-feed
(with-slots ((title hssg.blog.artifacts:title)
(description hssg.blog.artifacts:description)
(output hssg.blog.artifacts:output)
(url hssg.blog.artifacts:url))
blog
(let ((artifact (make-instance 'hssg:xml-artifact
:output (apply #'fad:merge-pathnames-as-file
`(,output
,(fad:pathname-as-file "rss.xml")))
:data `((:rss :version "2.0")
(:channel
(:title ,title)
(:link
,(format nil "~A/~{~A/~}" hssg:*site-url* url))
(:description ,description)
(:generator "HSSG")
(:language ,hssg:*site-language*)
(:docs "https://www.rssboard.org/rss-2-0")
("lastBuildDate"
,(local-time:format-rfc1123-timestring nil (local-time:now)))
,@(mapcar (lambda (post)
(post->rss-post post (cons hssg:*site-url* url)))
posts))))))
(hssg:write-artifact artifact)))))
(defun post->rss-post (post url) (defun post->rss-post (post url)
"Converts one post artifact to S-XML suitable for a post inside the RSS feed" "Converts one post artifact to S-XML suitable for a post inside the RSS feed"
(declare (type hssg.blog.artifacts:post-artifact post) (declare (type hssg.blog.artifacts:post-artifact post)
@ -82,3 +53,34 @@
(string data) (string data)
(list (list
(apply #'concatenate 'string (mapcar #'detag (cdr data))))))) (apply #'concatenate 'string (mapcar #'detag (cdr data)))))))
(defun rss->xml (rss-feed)
"Transforms an RSS feed to an XML artifact."
(with-slots ((posts hssg.blog.artifacts:posts)
(blog hssg.blog.artifacts:blog))
rss-feed
(with-slots ((title hssg.blog.artifacts:title)
(description hssg.blog.artifacts:description)
; (output hssg.blog.artifacts:output)
(url hssg.blog.artifacts:url))
blog
(make-instance 'hssg:xml-artifact
:output (fad:pathname-as-file "rss.xml")
:data `((:rss :version "2.0")
(:channel
(:title ,title)
(:link
,(format nil "~A/~{~A/~}" hssg:*site-url* url))
(:description ,description)
(:generator "HSSG")
(:language ,hssg:*site-language*)
(:docs "https://www.rssboard.org/rss-2-0")
("lastBuildDate"
,(local-time:format-rfc1123-timestring nil (local-time:now)))
,@(mapcar (lambda (post)
(post->rss-post post (cons hssg:*site-url* url)))
posts)))))))
(defmethod hssg:derive-artifact ((rss-feed rss-feed-artifact))
(let ((xml-artifact (rss->xml rss-feed)))
(hssg:derive-artifact xml-artifact)))

66
src/blog/artifacts/tag.lisp
View file

@ -19,34 +19,6 @@
;;;; 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.blog.artifact.tag) (in-package #:hssg.blog.artifact.tag)
(defmethod hssg:write-artifact ((tag tag-artifact))
(with-slots ((blog hssg.blog.artifacts:blog)
(name hssg.blog.artifacts:name)
(posts hssg.blog.artifacts:posts))
tag
(dolist (index-page (hssg.blog.artifact.util:collect-index-pages posts blog (list "tags" name)))
(hssg:write-artifact index-page))))
(defmethod hssg:write-artifact ((tags tags-artifact))
(with-slots ((items hssg.blog.artifacts:items)
(blog hssg.blog.artifacts:blog))
tags
(let ((artifact (make-instance 'hssg:html-artifact
:data `((:tags . ,items)
(:blog . ,blog)
,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates
'hssg.blog.template:tags
'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template))
:output (fad:merge-pathnames-as-file
(slot-value blog 'hssg.blog.artifacts:output)
(fad:pathname-as-directory (hssg.blog.i18n:localise :url-tags))
(fad:pathname-as-file "index.html")))))
(hssg:write-artifact artifact))
(dolist (tag items)
(hssg:write-artifact tag))))
(defun fetch-tag (tags name) (defun fetch-tag (tags name)
"Retrieve the tag object with a given NAME from a BLOG artifact; if there is "Retrieve the tag object with a given NAME from a BLOG artifact; if there is
no tag object it is created and registered first." no tag object it is created and registered first."
@ -65,3 +37,41 @@
(with-slots ((posts hssg.blog.artifacts:posts)) (with-slots ((posts hssg.blog.artifacts:posts))
(fetch-tag tags name) (fetch-tag tags name)
(push post posts))) (push post posts)))
(defun tags->html (items blog)
"Reduce them ITEMS of a TAGS-ARTIFACT instance to an HTML page artifact."
(make-instance 'hssg:html-artifact
:data `((:tags . ,items)
(:blog . ,blog)
,@(slot-value blog 'hssg.blog.artifacts:initial))
:template (hssg:chain-templates
'hssg.blog.template:tags
'hssg.blog.template:blog-page
(slot-value blog 'hssg.blog.artifacts:template))
:output (fad:merge-pathnames-as-file
(fad:pathname-as-directory (hssg.blog.i18n:localise :url-tags))
(fad:pathname-as-file "index.html"))))
(defmethod hssg:derive-artifact ((tag tag-artifact))
"Compound instruction, one instruction per index page."
(with-slots ((blog hssg.blog.artifacts:blog)
(name hssg.blog.artifacts:name)
(posts hssg.blog.artifacts:posts))
tag
(make-instance 'hssg:compound-instruction
:instructions (mapcar
#'hssg:derive-artifact
;; FIXME: use localised name instead of "tags"
(collect-index-pages posts blog (list "tags" name))))))
(defmethod hssg:derive-artifact ((tags tags-artifact))
"Compound instruction: one instructions for the whole tags page and one
instruction per individual tag (which itself is a compound instruction)."
(with-slots ((items hssg.blog.artifacts:items)
(blog hssg.blog.artifacts:blog))
tags
(let ((tags-page (hssg:derive-artifact (tags->html items blog)))
(tag-indices (mapcar #'hssg:derive-artifact items)))
(make-instance 'hssg:compound-instruction
:instructions (cons tags-page tag-indices)))))

1
src/blog/artifacts/util.lisp
View file

@ -44,4 +44,3 @@
(setf previous artifact) (setf previous artifact)
(push artifact result)) (push artifact result))
(setf posts remainder)))) (setf posts remainder))))

17
src/blog/facade.lisp
View file

@ -20,23 +20,20 @@
;;;; 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.blog.facade) (in-package #:hssg.blog.facade)
(defun make-blog (input output &key title url description template top) (defun make-blog (input &key (title "Blog") (url (list)) (description "") (template #'hssg:identity-template) (top ""))
"Constructor function which produces a blog artifact. Parameters: "Constructor function which produces a blog artifact. Parameters:
- INPUT: Pathname to the directory from which to read the blog - INPUT: Pathname to the directory from which to read the blog
- OUTPUT: Pathname to the directory where to write the blog artifact to
- TITLE: Title of the blog - TITLE: Title of the blog
- URL: URL path components to the blog, relative to the site root - URL: URL path components to the blog, relative to the site root
- TOP: Identifier to use as the top of the breadcrumbs - TOP: Identifier to use as the top of the breadcrumbs
- DESCRIPTION: Human-readable description, will be used for RSS feed - DESCRIPTION: Human-readable description, will be used for RSS feed
- TEMPLATE: Template to use for HTML pages" - TEMPLATE: Template to use for HTML pages"
(declare (type pathname input output) (declare (type pathname input)
(type string title description top) (type string title description top)
(type list url) (type list url)
(type hssg:template template)) (type hssg:template template))
(let ((result (make-instance 'hssg.blog.artifacts:blog-artifact (let ((result (make-instance 'hssg.blog.artifacts:blog-artifact
:title title :description description :title title :description description :url url :template template :top top))
:url url :output output
:template template :top top))
last-post) last-post)
(setf (slot-value (slot-value result 'hssg.blog.artifacts:categories) 'hssg.blog.artifacts:blog) result) (setf (slot-value (slot-value result 'hssg.blog.artifacts:categories) 'hssg.blog.artifacts:blog) result)
(setf (slot-value (slot-value result 'hssg.blog.artifacts:tags) 'hssg.blog.artifacts:blog) result) (setf (slot-value (slot-value result 'hssg.blog.artifacts:tags) 'hssg.blog.artifacts:blog) result)
@ -115,13 +112,9 @@
(push-post (car periods) post)))) (push-post (car periods) post))))
(defun add-static (blog pathname input-dir) (defun add-static (blog pathname input-dir)
(with-slots ((static hssg.blog.artifacts:static) (with-slots ((static hssg.blog.artifacts:static))
(output-dir hssg.blog.artifacts:output))
blog blog
(let ((artifact (hssg:make-directory-artifact (let ((artifact (hssg:make-directory-artifact input-dir pathname)))
pathname
input-dir
output-dir)))
(hssg:compound-artifact-push static artifact)))) (hssg:compound-artifact-push static artifact))))
(defmethod push-post ((period hssg.blog.period:day-period) post) (defmethod push-post ((period hssg.blog.period:day-period) post)

7
src/blog/package.lisp
View file

@ -43,7 +43,7 @@
(:use :cl :hssg.blog.util) (:use :cl :hssg.blog.util)
(:import-from #:hssg write-artifact) (:import-from #:hssg write-artifact)
(:export (:export
blog-artifact title description posts categories tags authors periods top url output template initial static blog-artifact title description posts categories tags authors periods top url template initial static
post-artifact blog slug content category author published modified status previous next metadata post-artifact blog slug content category author published modified status previous next metadata
categories-artifact items categories-artifact items
category-artifact name category-name category-artifact name category-name
@ -56,7 +56,7 @@
(defpackage #:hssg.blog.artifact.util (defpackage #:hssg.blog.artifact.util
(:documentation "Helper package, various reusable utility functions.") (:documentation "Helper package, various reusable utility functions.")
(:use :cl) (:use :cl)
(:export collect-index-pages)) (:export #:collect-index-pages))
(defpackage #:hssg.blog.artifact.archive (defpackage #:hssg.blog.artifact.archive
(:use :cl) (:use :cl)
@ -68,7 +68,7 @@
(:import-from #:hssg write-artifact) (:import-from #:hssg write-artifact)
(:import-from #:hssg.blog.util date-from-numbers date->year date->month date->day) (:import-from #:hssg.blog.util date-from-numbers date->year date->month date->day)
(:import-from #:hssg.blog.artifacts (:import-from #:hssg.blog.artifacts
blog-artifact posts categories tags authors periods title static output blog-artifact posts categories tags authors periods title static
categories-artifact items categories-artifact items
category-artifact category-artifact
tags-artifact tag-artifact tags-artifact tag-artifact
@ -94,6 +94,7 @@
(defpackage #:hssg.blog.artifact.tag (defpackage #:hssg.blog.artifact.tag
(:use :cl) (:use :cl)
(:import-from #:hssg.blog.artifacts tags-artifact tag-artifact) (:import-from #:hssg.blog.artifacts tags-artifact tag-artifact)
(:import-from #:hssg.blog.artifact.util #:collect-index-pages)
(:export add-post)) (:export add-post))
(defpackage #:hssg.blog.template (defpackage #:hssg.blog.template

16
src/hssg/filesystem.lisp
View file

@ -101,13 +101,17 @@ prepending a new base path to the output file."))
(defun copy-directory (from to) (defun copy-directory (from to)
"Recursively copies the contents of FROM to directory TO, overwriting it if "Recursively copies the contents of FROM to directory TO, overwriting it if
necessary." necessary."
(fad:walk-directory (uiop/filesystem:collect-sub*directories
from from
(lambda (pathname) (lambda (directory) (declare (ignore directory)) t)
(let* ((relative (enough-namestring pathname from)) (lambda (directory) (declare (ignore directory)) t)
(target (merge-pathnames relative to))) (lambda (directory)
(ensure-directories-exist target) (declare (type pathname directory))
(fad:copy-file pathname target :overwrite t)))) (dolist (file (uiop/filesystem:directory-files directory))
(let* ((relative (enough-namestring file (uiop/pathname:merge-pathnames* from)))
(target (merge-pathnames relative to)))
(ensure-directories-exist target)
(uiop:copy-file file target)))))
nil) nil)
(defun write-string-to-file (contents path) (defun write-string-to-file (contents path)

4
src/hssg/package.lisp
View file

@ -83,7 +83,7 @@
#:file-system-instruction #:file-system-instruction
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction #:write-string-contents #:copy-file #:copy-directory #:compound-instruction
#:write-to-filesystem) #:write-to-filesystem)
(:import-from #:hssg.artifact write-artifact artifacts html-artifact xml-artifact ) (:import-from #:hssg.artifact write-artifact #:derive-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)
(:import-from #:hssg.artifact.verbatim make-verbatim-artifact) (:import-from #:hssg.artifact.verbatim make-verbatim-artifact)
@ -98,7 +98,7 @@
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction #:write-string-contents #:copy-file #:copy-directory #:compound-instruction
#:write-to-filesystem #:write-to-filesystem
;; Artifact protocol ;; Artifact protocol
write-artifact write-artifact #:derive-artifact
;; Compound artifacts ;; Compound artifacts
make-compound-artifact compound-artifact-push make-compound-artifact compound-artifact-push

101
test/blog/artifacts/archive.lisp Normal file
View file

@ -0,0 +1,101 @@
;;;; SPDX-License-Identifier: AGPL-3.0-or-later
;;;; archive.lisp Implementation of blog post archive artifact
;;;;
;;;; 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-blog/test.artifact.archive
(:use #:cl)
(:import-from #:clunit
#:deftest #:deffixture #:defsuite
#:assert-true #:assert-false #:assert-equal #:assert-eq))
(in-package #:hssg-blog/test.artifact.archive)
(defsuite hssg-blog.artifact.archive (hssg-blog/test:main))
(defsuite hssg-blog.artifact.archive.derive (hssg-blog.artifact.archive))
(defsuite hssg-blog.artifact.archive.to-html (hssg-blog.artifact.archive))
;;; --- DERIVATION ------------------------------------------------------------
;;; NOTE: we do not test the content of the instruction, we will instead test
;;; the transformation from artifact to HTML page in a different suite.
(deffixture hssg-blog.artifact.archive.derive (@body)
(let ((blog (make-instance 'hssg.blog.artifacts:blog-artifact
:title "Dummy blog"
:description "A dummy blog for testing"
:url '("blog"))))
@body))
(deftest derive-artifact (hssg-blog.artifact.archive.derive)
(let* ((artifact (make-instance 'hssg.blog.artifacts:archive-page-artifact
:periods (list) :blog blog))
(instruction (hssg:derive-artifact artifact)))
(assert-true (typep instruction 'hssg:write-string-contents))
;; Probably cannot test contents reasonably here; should move
;; transformation from archive artifact to HTML artifact to a function
(with-slots ((path hssg.filesystem::path))
instruction
(assert-equal #p"archive/index.html" path))))
;;; --- TRANSFORMATION TO HTML ARTIFACT ---------------------------------------
(deffixture hssg-blog.artifact.archive.to-html (@body)
(let ((blog (make-instance 'hssg.blog.artifacts:blog-artifact
:title "Dummy blog"
:description "A dummy blog for testing"
:url '("blog")
:initial '((:content . (:body (:p "Hello world.") (:p . "Goodbye world.")))))))
@body))
(deftest references-blog (hssg-blog.artifact.archive.to-html)
"The blog reference refers to the same blog object."
(let* ((archive (make-instance 'hssg.blog.artifacts:archive-page-artifact
:blog blog :periods (list)))
(html (hssg.blog.artifact.archive::archive->html archive)))
(with-slots ((data hssg.artifact::data))
html
(assert-eq blog (cdr (assoc :blog data))))))
(clunit:run-test 'references-blog)
(deftest empty-archive (hssg-blog.artifact.archive.to-html)
"The list of periods is empty"
(let* ((archive (make-instance 'hssg.blog.artifacts:archive-page-artifact
:blog blog :periods (list)))
(html (hssg.blog.artifact.archive::archive->html archive)))
(with-slots ((data hssg.artifact::data))
html
(assert-false (cdr (assoc :periods data))))))
(deftest nonempty-archive (hssg-blog.artifact.archive.to-html)
"The periods are transferred to the data."
(let* ((periods '(a b c))
(archive (make-instance 'hssg.blog.artifacts:archive-page-artifact
:blog blog :periods periods))
(html (hssg.blog.artifact.archive::archive->html archive)))
(with-slots ((data hssg.artifact::data))
html
(assert-equal periods (cdr (assoc :periods data))))))
(deftest initial-data (hssg-blog.artifact.archive.to-html)
"The initial data from the blog is included."
(let* ((archive (make-instance 'hssg.blog.artifacts:archive-page-artifact
:blog blog :periods (list)))
(html (hssg.blog.artifact.archive::archive->html archive)))
(with-slots ((data hssg.artifact::data))
html
(assert-equal (slot-value blog 'hssg.blog.artifacts:initial) (cddr data))
(assert-true t))))

30
test/blog/main.lisp Normal file
View file

@ -0,0 +1,30 @@
;;;; SPDX-License-Identifier AGPL-3.0-or-later
;;;; main.lisp Entry point into the HSSG-BLOG 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/>.(in-package #:hssg.artifact)
(defpackage #:hssg-blog/test
(:documentation "Main test package")
(:use #:cl)
(:export test-all main))
(in-package #:hssg-blog/test)
(defun test-all ()
(clunit:run-suite 'main))
(clunit:defsuite main ())

10
test/hssg/artifacts/compound.lisp
View file

@ -47,14 +47,14 @@
;;; --- CONSTRUCTOR ----------------------------------------------------------- ;;; --- CONSTRUCTOR -----------------------------------------------------------
(deftest make-empty (hssg.artifact.compound.constructor) (deftest make-empty-compound-artifact (hssg.artifact.compound.constructor)
"An empty artifact has no children." "An empty artifact has no children."
(let ((compound (hssg:make-compound-artifact))) (let ((compound (hssg:make-compound-artifact)))
(with-slots ((artifacts hssg.artifact:artifacts)) (with-slots ((artifacts hssg.artifact:artifacts))
compound compound
(clunit:assert-false artifacts)))) (clunit:assert-false artifacts))))
(deftest make-nonempty (hssg.artifact.compound.constructor) (deftest make-nonempty-compound-artifact (hssg.artifact.compound.constructor)
"A nonempty artifact has children." "A nonempty artifact has children."
(let* ((dummy1 (make-instance 'dummy-artifact)) (let* ((dummy1 (make-instance 'dummy-artifact))
(dummy2 (make-instance 'dummy-artifact)) (dummy2 (make-instance 'dummy-artifact))
@ -68,7 +68,7 @@
;;; --- MUTATION -------------------------------------------------------------- ;;; --- MUTATION --------------------------------------------------------------
(deftest push-artifact (hssg.artifact.compound.mutation) (deftest compound-artifact-push (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)) (dummy1 (make-instance 'dummy-artifact))
@ -84,7 +84,7 @@
;;; --- DERIVATIVES ----------------------------------------------------------- ;;; --- DERIVATIVES -----------------------------------------------------------
(deftest derive-empty (hssg.artifact.compound.derivation) (deftest derive-empty-compound-artifact (hssg.artifact.compound.derivation)
"Deriving an empty artifact yields and empty struction." "Deriving an empty artifact yields and empty struction."
(let* ((artifact (hssg:make-compound-artifact)) (let* ((artifact (hssg:make-compound-artifact))
(instruction (hssg.artifact:derive-artifact artifact))) (instruction (hssg.artifact:derive-artifact artifact)))
@ -93,7 +93,7 @@
instruction instruction
(null instructions)))) (null instructions))))
(deftest derive-nonempty (hssg.artifact.compound.derivation) (deftest derive-nonempty-compound-artifact (hssg.artifact.compound.derivation)
"Deriving a non-empty artifact in turn derives each of the children." "Deriving a non-empty artifact in turn derives each of the children."
(let* ((dummy1 (make-instance 'dummy-artifact)) (let* ((dummy1 (make-instance 'dummy-artifact))
(dummy2 (make-instance 'dummy-artifact)) (dummy2 (make-instance 'dummy-artifact))

2
test/hssg/artifacts/directory.lisp
View file

@ -27,7 +27,7 @@
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
(deftest derive-artifact (hssg.artifact.directory) (deftest derive-directory-artifact (hssg.artifact.directory)
(let* ((artifact (hssg:make-directory-artifact #p"content/blog" #p"assets/images")) (let* ((artifact (hssg:make-directory-artifact #p"content/blog" #p"assets/images"))
(instruction (hssg.artifact:derive-artifact artifact))) (instruction (hssg.artifact:derive-artifact artifact)))
(assert-true (typep instruction 'hssg:copy-directory)) (assert-true (typep instruction 'hssg:copy-directory))

8
test/hssg/artifacts/html.lisp
View file

@ -23,7 +23,7 @@
(:import-from #:hssg.artifact #:html-artifact #:derive-artifact)) (:import-from #:hssg.artifact #:html-artifact #:derive-artifact))
(in-package #:hssg/test/artifact/html) (in-package #:hssg/test/artifact/html)
(clunit:defsuite hssg.artifact.html (hssg/test:hssg)) (defsuite hssg.artifact.html (hssg/test:hssg))
(hssg:deftemplate dummy-template (content) (hssg:deftemplate dummy-template (content)
(:content (:content
@ -34,18 +34,16 @@
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
(deftest derive-artifact (hssg.artifact.html) (deftest derive-html-artifact (hssg.artifact.html)
(let* ((artifact (make-instance 'hssg:html-artifact (let* ((artifact (make-instance 'hssg:html-artifact
:data '((:content . ((:p "Hello world!")))) :data '((:content . ((:p "Hello world!"))))
:template #'dummy-template :template #'dummy-template
:output #p"blog/index.html")) :output #p"blog/index.html"))
(instruction (derive-artifact artifact))) (instruction (derive-artifact artifact)))
nil (assert-true (typep instruction 'hssg:write-string-contents))
(assert-true (typep instruction 'hssgwrite-string-contents))
(with-slots ((contents hssg.filesystem::contents) (with-slots ((contents hssg.filesystem::contents)
(path hssg.filesystem::path)) (path hssg.filesystem::path))
instruction instruction
nil
(assert-equal "<!DOCTYPE html> (assert-equal "<!DOCTYPE html>
<html><head></head><body><p>Hello world!</p></body></html>" <html><head></head><body><p>Hello world!</p></body></html>"
contents) contents)

18
test/hssg/artifacts/verbatim.lisp
View file

@ -29,19 +29,17 @@
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
(deftest constructor-function (hssg.artifact.verbatim.constructor) (deftest verbatim-artifact-constructor (hssg.artifact.verbatim.constructor)
(let ((base-dir #p"content/blog") (let ((artifact (hssg:make-verbatim-artifact #p"content/blog" #p"css/main.css")))
(file-name #p"css/main.css")) (with-slots ((directory hssg.artifact::directory)
(let ((artifact (hssg:make-verbatim-artifact base-dir file-name))) (file-name hssg.artifact::file-name))
(with-slots ((directory hssg.artifact::directory) artifact
(file-name hssg.artifact::file-name)) (assert-equal #p"content/blog" directory)
artifact (assert-equal #p"css/main.css" file-name))))
(assert-equal #p"content/blog" directory)
(assert-equal #p"css/main.css" file-name)))))
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
(deftest derive-artifact (hssg.artifact.verbatim.deriving) (deftest derive-verbatim-artifact (hssg.artifact.verbatim.deriving)
(let* ((artifact (hssg:make-verbatim-artifact #p"content/blog" #p"css/main.css")) (let* ((artifact (hssg:make-verbatim-artifact #p"content/blog" #p"css/main.css"))
(instruction (derive-artifact artifact))) (instruction (derive-artifact artifact)))
(with-slots ((base-path hssg.filesystem::base-path) (with-slots ((base-path hssg.filesystem::base-path)

2
test/hssg/artifacts/xml.lisp
View file

@ -30,7 +30,7 @@
;;; NOTE: we do not test the produced XML, only that some XML was produced in ;;; NOTE: we do not test the produced XML, only that some XML was produced in
;;; the first place. ;;; the first place.
(deftest derive-artifact (hssg.artifact.xml) (deftest derive-xml-artifact (hssg.artifact.xml)
(let* ((artifact (make-instance 'hssg:xml-artifact :data '((:foo . "bar")) :output #p"blog/rss.xml")) (let* ((artifact (make-instance 'hssg:xml-artifact :data '((:foo . "bar")) :output #p"blog/rss.xml"))
(instruction (derive-artifact artifact))) (instruction (derive-artifact artifact)))
(assert-true (typep instruction 'hssg:write-string-contents)) (assert-true (typep instruction 'hssg:write-string-contents))

35
test/hssg/file-system.lisp
View file

@ -160,3 +160,38 @@
(loop for instruction in written (loop for instruction in written
for dummy in (list dummy2 dummy1) ; Reverse order because of push! for dummy in (list dummy2 dummy1) ; Reverse order because of push!
do (assert-true (eq dummy instruction))))) do (assert-true (eq dummy instruction)))))
;;; --- HELPER FUNCTIONS ------------------------------------------------------
;;; Here we have to actually access the file system, so we will be working with
;;; temporary files
(defsuite hssg.filesystem.helper (hssg.filesystem))
(defsuite hssg.filesystem.helper.copy-directory (hssg.filesystem.helper))
(defun file-equal-p (p1 p2)
"Whether the contents of two files are the same."
(declare (type pathname p1 p2))
(let ((s1 (uiop/stream:read-file-string p1))
(s2 (uiop/stream:read-file-string p2)))
(string= s1 s2)))
(deffixture hssg.filesystem.helper.copy-directory (@body)
(let ((original (uiop/pathname:ensure-directory-pathname
#p"test/hssg/sample-files/directory-tree/"))
(copy (uiop/pathname:ensure-directory-pathname
#p"test/hssg/sample-files/copy-tree/")))
(declare (ignorable original copy))
(unwind-protect
(progn
@body)
(uiop/filesystem:delete-directory-tree
copy :if-does-not-exist :ignore :validate t))))
(deftest copy-directory (hssg.filesystem.helper.copy-directory)
(hssg.filesystem::copy-directory original copy)
(dolist (p '(#p"a.txt" #p"b.txt" #p"x/c.txt" #p"x/y/d.txt" #p"x/y/e.txt"))
(assert-true (file-equal-p
(fad:merge-pathnames-as-file original p)
(fad:merge-pathnames-as-file copy p)))))

2
test/hssg/main.lisp
View file

@ -1,6 +1,6 @@
;;;; SPDX-License-Identifier AGPL-3.0-or-later ;;;; SPDX-License-Identifier AGPL-3.0-or-later
;;;; compound.lisp Compound artifact implementation ;;;; main.lisp Entry point into the HSSG tests
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez ;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
;;;; ;;;;
;;;; This file is part of CL-HSSG. ;;;; This file is part of CL-HSSG.

11
test/hssg/sample-files/README.rst Normal file
View file

@ -0,0 +1,11 @@
.. default-role:: code
This directory contains a number of sample files and directories for testing
functions which need to operate on actual on-disc files.
`metadata.lisp`
A sample Lisp file such as they are used to create HTML pages.
`directory-tree`
A directory containing files and nested directories, used for functions
which operate recursively on a file tree.

5
test/hssg/sample-files/directory-tree/a.txt Normal file
View file

@ -0,0 +1,5 @@
_
/ \
/ _ \
/ ___ \
/_/ \_\

5
test/hssg/sample-files/directory-tree/b.txt Normal file
View file

@ -0,0 +1,5 @@
____
| __ )
| _ \
| |_) |
|____/

5
test/hssg/sample-files/directory-tree/x/c.txt Normal file
View file

@ -0,0 +1,5 @@
____
/ ___|
| |
| |___
\____|

5
test/hssg/sample-files/directory-tree/x/y/d.txt Normal file
View file

@ -0,0 +1,5 @@
____
| _ \
| | | |
| |_| |
|____/

5
test/hssg/sample-files/directory-tree/x/y/e.txt Normal file
View file

@ -0,0 +1,5 @@
_____
| ____|
| _|
| |___
|_____|

1
test/hssg/sample-files/metadata.lisp
View file

@ -1,3 +1,4 @@
;;; This file produces HSSG metadata when read by a Lisp reader
(defun throwaway-function () (defun throwaway-function ()
"This function must not leak out of this file" "This function must not leak out of this file"
"foo") "foo")