Construct public interface to blog plugin

The blog plugin now only exposes the blog artifact constructor method
and the configuration parameters.

TODO.rst

@@ -17,13 +17,11 @@ Features
 ========
 
 - Template: docstrings in template
+- Localization: Fall back to English if a particular key does not exist for the
+  target language
 
 Cleanup
 =======
 
 - How much of each artifact's internals need to be exposed? Make accessor
   functions? Constructor functions over `MAKE-INSTANCE`?
-- A proper blog plugin interface; we probably only want a constructor function
-  which will then instantiate a blog artifact which in turn will instantiate
-  all its subordinate artifacts. Thus the blog artifact acts as a façade to the
-  entire blog plugin.

hssg-blog.asd

@@ -53,4 +53,5 @@
                                                          (:file "category-tag")
                                                          (:file "index")
                                                          (:file "post")))
-                                           (:file "templates")))))))
+                                           (:file "templates")
+                                           (:file "facade")))))))

src/blog/artifacts/blog.lisp

@@ -59,126 +59,3 @@
     (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))))
-
-(defun directory-contents (path &key (test #'fad:directory-pathname-p))
-  "Contents of a directory, sorted alphabetically in ascending order."
-  (declare (type pathname path)
-           (type (function (pathname) boolean) test))
-  (sort (remove-if-not test (fad:list-directory path))
-        #'string<= :key #'namestring))
-
-(defun file-pathname-p (pathname)
-  "Whether PATHNAME names a file."
-  (not (fad:directory-pathname-p pathname)))
-
-(defun read-blog (title path url output template &key (description "") (initial '()) (top ""))
-  "Read the entire blog at file path PATH and write it to OUTPUT. All pages are
-  processed through the TEMPLATE."
-  (declare (type pathname path output)
-           (type string title top)
-           (type list initial url))
-  (let ((result (make-instance 'hssg.blog.artifacts:blog-artifact
-                               :title title :description description
-                               :url url :output output
-                               :template template :initial initial :top top))
-        (last-post nil))
-    (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)
-    (dolist (year (directory-contents path))
-      (dolist (month (directory-contents year))
-        (dolist (day (directory-contents month))
-          (dolist (entry (directory-contents day :test #'file-pathname-p))
-            (let ((post (read-post entry result)))
-              (when last-post
-                (setf (slot-value post 'hssg.blog.artifacts:previous) last-post)
-                (setf (slot-value last-post 'hssg.blog.artifacts:next) post))
-              (add-blog-post result post)
-              (setf last-post post)))
-          (dolist (directory (directory-contents day :test #'fad:directory-pathname-p))
-            (add-static
-              result
-              ;; The path needs to be relative, so we perform some PATHNAME trickery
-              (enough-namestring directory (fad:pathname-parent-directory year))
-              path)))))
-    result))
-
-(defun read-post (file-path blog)
-  "Reads one single blog post from file FILE-PATH, where the path of FILE-PATH
-  determines the date of the post and file name the slug of the post."
-  (declare (type pathname file-path)
-           (type blog-artifact blog))
-  (let ((date-components (mapcar #'parse-integer
-                                 (last (pathname-directory file-path) 3)))
-        (post (funcall (gethash (pathname-type file-path) hssg.blog:*BLOG-POST-READERS*)
-                       file-path)))
-    (hssg:let-metadata post
-        ((category :category hssg.blog.i18n:*default-category*)
-         (slug :slug (pathname-name file-path))
-         (title :title)
-         (author :author)
-         (tags :tags)
-         (published :published (apply #'date-from-numbers date-components))
-         (modified :modified)
-         (content :content))
-      (make-instance 'hssg.blog.artifacts:post-artifact :blog blog :slug slug :title title :content content
-                     :category category :tags tags :author author
-                     :published published
-                     :modified modified
-                     :metadata post))))
-
-(defun add-blog-post (blog post)
-  "Add a single blog post to the entire blog. The blog's author, category and
-  tags will also be registered."
-  (with-slots (posts tags authors categories) blog
-    (push post posts)
-    (with-slots ((category-name category)
-                 (post-tags tags)
-                 author)
-        post
-      (when category-name
-        (hssg.blog.artifact.category:add-post categories category-name post))
-      (when post-tags
-        (dolist (tag post-tags)
-          (hssg.blog.artifact.tag:add-post tags tag post)))
-      (when author
-        (push post (gethash author authors))))
-    ;; This assumes that incoming posts are ordered from oldest to newest!
-    (with-slots (periods) blog
-      (let ((year (local-time:timestamp-year (slot-value post 'hssg.blog.artifacts:published)))
-            (top-period (car periods)))
-        (when (or (not top-period) (not (= year (slot-value top-period 'hssg.blog.period:year))))
-          (push (make-instance 'hssg.blog.period:year-period :year year) periods)))
-      (push-post (car periods) post))))
-
-(defun add-static (blog pathname input-dir)
-  (with-slots (static (output-dir output)) blog
-    (with-slots ((artifacts hssg:artifacts)) static
-      (let ((artifact (hssg:make-directory-artifact
-                        pathname
-                        input-dir
-                        output-dir)))
-        (push artifact artifacts)))))
-
-(defmethod push-post ((period hssg.blog.period:day-period) post)
-  (with-slots ((posts hssg.blog.period:posts)) period
-    (push post posts)))
-
-(defmethod push-post ((period hssg.blog.period:month-period) post)
-  (with-slots ((days hssg.blog.period:days)) period
-    (let ((day (local-time:timestamp-day (slot-value post 'hssg.blog.artifacts:published))))
-      (let ((topmost (car days)))
-        (if (or (null topmost) (not (= day (slot-value topmost 'hssg.blog.period:day))))
-            (let ((day-period (make-instance 'hssg.blog.period:day-period :day day)))
-              (push day-period days)
-              (push-post day-period post))
-            (push-post topmost post))))))
-
-(defmethod push-post ((period hssg.blog.period:year-period) post)
-  (with-slots ((months hssg.blog.period:months)) period
-    (let ((month (local-time:timestamp-month (slot-value post 'hssg.blog.artifacts:published))))
-      (let ((topmost (car months)))
-        (if (or (null topmost) (not (= month (slot-value topmost 'hssg.blog.period:month))))
-            (let ((month-period (make-instance 'hssg.blog.period:month-period :month month)))
-              (push month-period months)
-              (push-post month-period post))
-            (push-post topmost post))))))

src/blog/facade.lisp

@@ -0,0 +1,151 @@
+;;;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;;;; facade.lisp  Implementation of the public interface to the blog plugin
+;;;;
+;;;; 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.blog.facade)
+
+(defun make-blog (input output &key title url description 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)
+           (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))
+        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)
+    (dolist (year (hssg.blog.util:directory-contents input))
+      (dolist (month (hssg.blog.util:directory-contents year))
+        (dolist (day (hssg.blog.util:directory-contents month))
+          (dolist (entry (hssg.blog.util:directory-contents day :test #'file-pathname-p))
+            (let ((post (read-post entry result)))
+              (when last-post
+                (setf (slot-value post 'hssg.blog.artifacts:previous) last-post)
+                (setf (slot-value last-post 'hssg.blog.artifacts:next) post))
+              (add-blog-post result post)
+              (setf last-post post)))
+          (dolist (directory (hssg.blog.util:directory-contents day :test #'fad:directory-pathname-p))
+            (add-static
+              result
+              ;; The path needs to be relative, so we perform some PATHNAME trickery
+              (enough-namestring directory (fad:pathname-parent-directory year))
+              input)))))
+    result))
+
+(defun file-pathname-p (pathname)
+  "Whether PATHNAME names a file."
+  (not (fad:directory-pathname-p pathname)))
+
+(defun read-post (file-path blog)
+  "Reads one single blog post from file FILE-PATH, where the path of FILE-PATH
+  determines the date of the post and file name the slug of the post."
+  (declare (type pathname file-path)
+           (type hssg.blog.artifacts:blog-artifact blog))
+  (let ((date-components (mapcar #'parse-integer
+                                 (last (pathname-directory file-path) 3)))
+        (post (funcall (gethash (pathname-type file-path) hssg.blog:*BLOG-POST-READERS*)
+                       file-path)))
+    (hssg:let-metadata post
+        ((category :category hssg.blog.i18n:*default-category*)
+         (slug :slug (pathname-name file-path))
+         (title :title)
+         (author :author)
+         (tags :tags)
+         (published :published (apply #'hssg.blog.util:date-from-numbers date-components))
+         (modified :modified)
+         (content :content))
+      (make-instance 'hssg.blog.artifacts:post-artifact :blog blog :slug slug :title title :content content
+                     :category category :tags tags :author author
+                     :published published
+                     :modified modified
+                     :metadata post))))
+
+(defun add-blog-post (blog post)
+  "Add a single blog post to the entire blog. The blog's author, category and
+  tags will also be registered."
+  (with-slots ((posts hssg.blog.artifacts:posts)
+               (tags hssg.blog.artifacts:tags)
+               (authors hssg.blog.artifacts:authors)
+               (categories hssg.blog.artifacts:categories))
+      blog
+    (push post posts)
+    (with-slots ((category-name hssg.blog.artifacts:category)
+                 (post-tags hssg.blog.artifacts:tags)
+                 (author hssg.blog.artifacts:author))
+        post
+      (when category-name
+        (hssg.blog.artifact.category:add-post categories category-name post))
+      (when post-tags
+        (dolist (tag post-tags)
+          (hssg.blog.artifact.tag:add-post tags tag post)))
+      (when author
+        (push post (gethash author authors))))
+    ;; This assumes that incoming posts are ordered from oldest to newest!
+    (with-slots ((periods hssg.blog.artifacts:periods)) blog
+      (let ((year (local-time:timestamp-year (slot-value post 'hssg.blog.artifacts:published)))
+            (top-period (car periods)))
+        (when (or (not top-period) (not (= year (slot-value top-period 'hssg.blog.period:year))))
+          (push (make-instance 'hssg.blog.period:year-period :year year) periods)))
+      (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))
+      blog
+    (with-slots ((artifacts hssg:artifacts))
+        static
+      (let ((artifact (hssg:make-directory-artifact
+                        pathname
+                        input-dir
+                        output-dir)))
+        (push artifact artifacts)))))
+
+(defmethod push-post ((period hssg.blog.period:day-period) post)
+  (with-slots ((posts hssg.blog.period:posts)) period
+    (push post posts)))
+
+(defmethod push-post ((period hssg.blog.period:month-period) post)
+  (with-slots ((days hssg.blog.period:days)) period
+    (let ((day (local-time:timestamp-day (slot-value post 'hssg.blog.artifacts:published))))
+      (let ((topmost (car days)))
+        (if (or (null topmost) (not (= day (slot-value topmost 'hssg.blog.period:day))))
+            (let ((day-period (make-instance 'hssg.blog.period:day-period :day day)))
+              (push day-period days)
+              (push-post day-period post))
+            (push-post topmost post))))))
+
+(defmethod push-post ((period hssg.blog.period:year-period) post)
+  (with-slots ((months hssg.blog.period:months)) period
+    (let ((month (local-time:timestamp-month (slot-value post 'hssg.blog.artifacts:published))))
+      (let ((topmost (car months)))
+        (if (or (null topmost) (not (= month (slot-value topmost 'hssg.blog.period:month))))
+            (let ((month-period (make-instance 'hssg.blog.period:month-period :month month)))
+              (push month-period months)
+              (push-post month-period post))
+            (push-post topmost post))))))

src/blog/package.lisp

@@ -23,7 +23,7 @@
   (:use :cl)
   (:export range date->year break-list
            date-from-numbers date->month date->day date->string date->url date->pathname
-           intersperse))
+           intersperse directory-contents))
 
 (defpackage #:hssg.blog.i18n
   (:documentation "Internationalisation support")
@@ -72,8 +72,7 @@
                 categories-artifact items
                 category-artifact
                 tags-artifact tag-artifact
-                post-artifact blog slug content category tags author published modified)
+                post-artifact blog slug content category tags author published modified))
-  (:export read-blog))
 
 (defpackage #:hssg.blog.artifact.category
   (:use :cl)
@@ -127,11 +126,17 @@
   (:use :cl)
   (:export post-tag->sxml pager->sxml))
 
+(defpackage #:hssg.blog.facade
+  (:use :cl)
+  (:export make-blog))
+
 (defpackage #:hssg.blog
   (:documentation "CommonMark parser extension for HSSG; parses CommonMark
   files to SXML trees")
   (:use #:cl)
-  (:import-from #:hssg.blog.artifacts.blog read-blog)
+  (:import-from #:hssg.blog.i18n *month-names* *default-category* *localisations*)
-  (:export read-blog
+  (:import-from #:hssg.blog.facade make-blog)
+  (:export make-blog
+           *month-names* *default-category* *localisations*
            *posts-per-page*
            *blog-post-readers*))

src/blog/util.lisp

@@ -87,3 +87,11 @@
     (dolist (current list (nreverse (cdr result)))
       (push current result)
       (push item result))))
+
+(defun directory-contents (path &key (test #'fad:directory-pathname-p))
+  "Contents of a directory, sorted alphabetically in ascending order."
+  (declare (type pathname path)
+           (type (function (pathname) boolean) test))
+  (sort (remove-if-not test (fad:list-directory path))
+        #'string<= :key #'namestring))
+

src/hssg/package.lisp

@@ -52,7 +52,8 @@
 (defpackage #:hssg.template
   (:documentation "HTML template macros; templates transform SHTML aslists.")
   (:use #:cl)
-  (:export deftemplate template let-metadata apply-template identity-template chain-templates))
+  (:export deftemplate template let-metadata apply-template identity-template
+           chain-templates template-with-data))
 
 (defpackage #:hssg
   (:documentation "The hackable static site generator")
@@ -61,11 +62,11 @@
   (:import-from #:hssg.artifact.verbatim make-verbatim-artifact)
   (:import-from #:hssg.artifact.directory make-directory-artifact)
   (:import-from #:hssg.artifact.html static-page read-html-lisp)
-  (:import-from #:hssg.template deftemplate template let-metadata apply-template identity-template chain-templates)
+  (:import-from #:hssg.template deftemplate template let-metadata apply-template identity-template
+                chain-templates template-with-data)
   (:export
     *site-url* *site-language*
     write-artifact compound-artifact artifacts
     html-artifact xml-artifact static-page read-html-lisp
     make-verbatim-artifact make-directory-artifact
-    deftemplate template let-metadata apply-template identity-template chain-templates))
+    deftemplate template let-metadata apply-template identity-template chain-templates template-with-data))
-(unintern 'hssg:xml-artifact)

src/hssg/template.lisp

@@ -116,3 +116,10 @@
       (dolist (tmp templates result)
         (declare (type template tmp))
         (setf result (apply-template tmp result))))))
+
+(defun template-with-data (template initial-data)
+  "Returns a new template which calls TEMPLATE with INITIAL-DATA and the data
+  passed to the template."
+  (declare (type template template)
+           (type list initial-data))
+  (lambda (data) (funcall template (concatenate 'list data initial-data))))