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"
:depends-on ("hssg" "cmark" "cl-fad")
:serial t
:components ((module "src"
:components ((:module "src"
:components ((:module "blog"
:components ((:file "package")
(:file "config")
@ -54,4 +54,21 @@
(:file "index")
(:file "post")))
(: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>"
:license "AGPL-3.0-or-later"
:version "0.0.0"
:depends-on ("alexandria" "cl-fad" "local-time" "plump")
:depends-on ("alexandria" "cl-fad" "uiop" "local-time" "plump")
:serial t
:components ((:module "src"
:components ((:module "hssg"
@ -49,7 +49,7 @@
:author "HiPhish <hiphish@posteo.de>"
:license "AGPL-3.0-or-later"
:version "0.0.0"
:depends-on ("hssg" "clunit2")
:depends-on ("hssg" "clunit2" "uiop")
:serial t
:perform (test-op (o s)
(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/>.
(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)
(blog hssg.blog.artifacts:blog))
archive
(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)
(initial hssg.blog.artifacts:initial))
blog
@ -38,7 +60,6 @@
'hssg.blog.template:blog-page
template)
:output (apply #'fad:merge-pathnames-as-file
`(,output
,(fad:pathname-as-directory "archive")
`(,(fad:pathname-as-directory "archive")
,(fad:pathname-as-file "index.html"))))))
(hssg:write-artifact html-page)))))
(hssg:derive-artifact html-page)))))

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

@ -19,43 +19,53 @@
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
(in-package #:hssg.blog.artifacts.blog)
(defmethod hssg:write-artifact ((blog blog-artifact))
(with-slots (posts categories tags periods output static) blog
(with-slots (items) categories
(setf items (sort items #'string<= :key #'hssg.blog.artifacts:category-name)))
(with-slots (items) tags
(setf items (sort items #'>= :key (lambda (tag) (length (slot-value tag 'hssg.blog.artifacts:posts))))))
(dolist (post posts)
(write-artifact post))
(dolist (index-page (hssg.blog.artifact.util:collect-index-pages posts blog '()))
(write-artifact index-page))
(dolist (year-period periods)
(with-slots ((year hssg.blog.period:year)
(months hssg.blog.period:months))
year-period
(let ((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
:prev nil
:next nil
: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
(defun derive-month-period (month-period year 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
: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))))
(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
(setf items (sort items #'string<= :key #'hssg.blog.artifacts:category-name)))
(with-slots (items) tags
(setf items (sort items #'>= :key (lambda (tag) (length (slot-value tag 'hssg.blog.artifacts:posts))))))
(let ((artifacts (list
static
categories
tags
(make-instance 'hssg.blog.artifacts:archive-page-artifact :periods periods :blog blog)
(make-instance 'hssg.blog.artifacts:rss-feed-artifact :posts posts :blog blog))))
(make-instance 'hssg:compound-instruction
:instructions
(concatenate
'list
(mapcar (lambda (year-period) (derive-year-period year-period blog)) periods)
(mapcar #'hssg:derive-artifact posts)
(mapcar #'hssg:derive-artifact (hssg.blog.artifact.util:collect-index-pages posts blog '()))
(mapcar #'hssg:derive-artifact artifacts))))))

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

@ -19,35 +19,6 @@
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
(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)
"Retrieve the category object with a given NAME from a BLOG artifact; if
there is no category object it is created and registered first."
@ -62,6 +33,47 @@
result))))
(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))
(fetch-category categories name)
(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.")
(description :initarg :description :initform "" :type string
: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.")
(categories :initform (make-instance 'categories-artifact) :type categories-artifact
:documentation "Collection of categories of the blog")
@ -35,15 +35,13 @@
:documentation "Collection of tags of the blog")
(authors :initform (make-hash-table :test 'equal) :type hash-table
: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.")
(top :initarg :top :initform "" :type string
:documentation "Identifier to use as the top of the breadcrumbs")
(url :initarg :url :type list
:documentation "URL of the blog as a list of URL path strings, relative
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
:documentation "Base template to apply to all pages")
(initial :initarg :initial :initform '() :type list
@ -121,9 +119,9 @@
:documentation "Number of this page among all pages")
(total :initform 1 :initarg :total :type (integer 1)
: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")
(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")
(blog :initarg :blog :type blog-artifact
:documentation "The blog instance this index belongs to."))

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

@ -19,14 +19,25 @@
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
(in-package #:hssg.blog.artifact.index-page)
(defmethod hssg:write-artifact ((page index-page-artifact))
(defun url-to-breadcrumbs (url)
"Converts a URL (list of strings) to breadcrums (list of a-lists)."
(maplist (lambda (items)
(let ((level (1- (length items))))
(if (zerop level)
`((:title . ,(car items)))
`((:title . ,(car items))
(:url . ,(format nil "~V@{~A/~:*~}" level ".."))))))
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
(let ((artifact (make-instance 'hssg:html-artifact
(make-instance 'hssg:html-artifact
:data `((:page . ,number)
(:pages . ,total)
(:blog . ,blog)
@ -39,17 +50,10 @@
'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)
`(,@(mapcar #'fad:pathname-as-directory url)
,(fad:pathname-as-file "index.html"))))))
(hssg:write-artifact artifact))))
(defun url-to-breadcrumbs (url)
"Converts a URL (list of strings) to breadcrums (list of a-lists)."
(maplist (lambda (items)
(let ((level (1- (length items))))
(if (zerop level)
`((:title . ,(car items)))
`((:title . ,(car items))
(:url . ,(format nil "~V@{~A/~:*~}" level ".."))))))
url))
(defmethod hssg:derive-artifact ((page index-page-artifact))
(let ((html-page (page->html page)))
(hssg:derive-artifact html-page)))

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

@ -19,7 +19,9 @@
;;;; along with CL-HSSG If not, see <https://www.gnu.org/licenses/>.
(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)
(slug hssg.blog.artifacts:slug)
(title hssg.blog.artifacts:title)
@ -34,7 +36,7 @@
(next hssg.blog.artifacts:next)
(metadata hssg.blog.artifacts:metadata))
post
(let ((artifact (make-instance 'hssg.artifact:html-artifact
(make-instance 'hssg.artifact:html-artifact
:data `((:blog . ,blog)
(:post . ((:slug . ,slug)
(:title . ,title)
@ -54,9 +56,10 @@
'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)
(hssg.blog.util:date->pathname published)
(fad:pathname-as-directory slug)
(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/>.
(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)
"Converts one post artifact to S-XML suitable for a post inside the RSS feed"
(declare (type hssg.blog.artifacts:post-artifact post)
@ -82,3 +53,34 @@
(string data)
(list
(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/>.
(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)
"Retrieve the tag object with a given NAME from a BLOG artifact; if there is
no tag object it is created and registered first."
@ -65,3 +37,41 @@
(with-slots ((posts hssg.blog.artifacts:posts))
(fetch-tag tags name)
(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)
(push artifact result))
(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/>.
(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:
- 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
- URL: URL path components to the blog, relative to the site root
- TOP: Identifier to use as the top of the breadcrumbs
- DESCRIPTION: Human-readable description, will be used for RSS feed
- TEMPLATE: Template to use for HTML pages"
(declare (type pathname input output)
(declare (type pathname input)
(type string title description top)
(type list url)
(type hssg:template template))
(let ((result (make-instance 'hssg.blog.artifacts:blog-artifact
:title title :description description
:url url :output output
:template template :top top))
:title title :description description :url url :template template :top top))
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:tags) 'hssg.blog.artifacts:blog) result)
@ -115,13 +112,9 @@
(push-post (car periods) post))))
(defun add-static (blog pathname input-dir)
(with-slots ((static hssg.blog.artifacts:static)
(output-dir hssg.blog.artifacts:output))
(with-slots ((static hssg.blog.artifacts:static))
blog
(let ((artifact (hssg:make-directory-artifact
pathname
input-dir
output-dir)))
(let ((artifact (hssg:make-directory-artifact input-dir pathname)))
(hssg:compound-artifact-push static artifact))))
(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)
(:import-from #:hssg write-artifact)
(: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
categories-artifact items
category-artifact name category-name
@ -56,7 +56,7 @@
(defpackage #:hssg.blog.artifact.util
(:documentation "Helper package, various reusable utility functions.")
(:use :cl)
(:export collect-index-pages))
(:export #:collect-index-pages))
(defpackage #:hssg.blog.artifact.archive
(:use :cl)
@ -68,7 +68,7 @@
(:import-from #:hssg write-artifact)
(:import-from #:hssg.blog.util date-from-numbers date->year date->month date->day)
(: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
category-artifact
tags-artifact tag-artifact
@ -94,6 +94,7 @@
(defpackage #:hssg.blog.artifact.tag
(:use :cl)
(:import-from #:hssg.blog.artifacts tags-artifact tag-artifact)
(:import-from #:hssg.blog.artifact.util #:collect-index-pages)
(:export add-post))
(defpackage #:hssg.blog.template

12
src/hssg/filesystem.lisp
View file

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

4
src/hssg/package.lisp
View file

@ -83,7 +83,7 @@
#:file-system-instruction
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction
#:write-to-filesystem)
(:import-from #:hssg.artifact write-artifact artifacts html-artifact xml-artifact )
(:import-from #:hssg.artifact write-artifact #:derive-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)
(:import-from #:hssg.artifact.verbatim make-verbatim-artifact)
@ -98,7 +98,7 @@
#:write-string-contents #:copy-file #:copy-directory #:compound-instruction
#:write-to-filesystem
;; Artifact protocol
write-artifact
write-artifact #:derive-artifact
;; Compound artifacts
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 -----------------------------------------------------------
(deftest make-empty (hssg.artifact.compound.constructor)
(deftest make-empty-compound-artifact (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))))
(deftest make-nonempty (hssg.artifact.compound.constructor)
(deftest make-nonempty-compound-artifact (hssg.artifact.compound.constructor)
"A nonempty artifact has children."
(let* ((dummy1 (make-instance 'dummy-artifact))
(dummy2 (make-instance 'dummy-artifact))
@ -68,7 +68,7 @@
;;; --- 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"
(let ((compound (hssg:make-compound-artifact))
(dummy1 (make-instance 'dummy-artifact))
@ -84,7 +84,7 @@
;;; --- 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."
(let* ((artifact (hssg:make-compound-artifact))
(instruction (hssg.artifact:derive-artifact artifact)))
@ -93,7 +93,7 @@
instruction
(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."
(let* ((dummy1 (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"))
(instruction (hssg.artifact:derive-artifact artifact)))
(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))
(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)
(: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
: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))
(assert-true (typep instruction 'hssg:write-string-contents))
(with-slots ((contents hssg.filesystem::contents)
(path hssg.filesystem::path))
instruction
nil
(assert-equal "<!DOCTYPE html>
<html><head></head><body><p>Hello world!</p></body></html>"
contents)

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

@ -29,19 +29,17 @@
;;; ---------------------------------------------------------------------------
(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)))
(deftest verbatim-artifact-constructor (hssg.artifact.verbatim.constructor)
(let ((artifact (hssg:make-verbatim-artifact #p"content/blog" #p"css/main.css")))
(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)))))
(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"))
(instruction (derive-artifact artifact)))
(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
;;; 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"))
(instruction (derive-artifact artifact)))
(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
for dummy in (list dummy2 dummy1) ; Reverse order because of push!
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
;;;; compound.lisp Compound artifact implementation
;;;; main.lisp Entry point into the HSSG tests
;;;; Copyright (C) 2022 Alejandro "HiPhish" Sanchez
;;;;
;;;; 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 ()
"This function must not leak out of this file"
"foo")