diff --git a/TODO.rst b/TODO.rst index ec5ee3e..0e41298 100644 --- a/TODO.rst +++ b/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. diff --git a/hssg-blog.asd b/hssg-blog.asd index 79ce648..678cf02 100644 --- a/hssg-blog.asd +++ b/hssg-blog.asd @@ -53,4 +53,5 @@ (:file "category-tag") (:file "index") (:file "post"))) - (:file "templates"))))))) + (:file "templates") + (:file "facade"))))))) diff --git a/src/blog/artifacts/blog.lisp b/src/blog/artifacts/blog.lisp index 1045511..80f97c7 100644 --- a/src/blog/artifacts/blog.lisp +++ b/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)))))) diff --git a/src/blog/facade.lisp b/src/blog/facade.lisp new file mode 100644 index 0000000..3913693 --- /dev/null +++ b/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 . +(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)))))) diff --git a/src/blog/package.lisp b/src/blog/package.lisp index c664170..af4373b 100644 --- a/src/blog/package.lisp +++ b/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) - (:export read-blog)) + post-artifact blog slug content category tags author published modified)) (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) - (:export read-blog + (:import-from #:hssg.blog.i18n *month-names* *default-category* *localisations*) + (:import-from #:hssg.blog.facade make-blog) + (:export make-blog + *month-names* *default-category* *localisations* *posts-per-page* *blog-post-readers*)) diff --git a/src/blog/util.lisp b/src/blog/util.lisp index bef99f8..9a5ad43 100644 --- a/src/blog/util.lisp +++ b/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)) + diff --git a/src/hssg/package.lisp b/src/hssg/package.lisp index 479ec66..dcee286 100644 --- a/src/hssg/package.lisp +++ b/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)) -(unintern 'hssg:xml-artifact) + deftemplate template let-metadata apply-template identity-template chain-templates template-with-data)) diff --git a/src/hssg/template.lisp b/src/hssg/template.lisp index b9ca10b..5f6dbd4 100644 --- a/src/hssg/template.lisp +++ b/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))))