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

Construct public interface to blog plugin

Browse source 
The blog plugin now only exposes the blog artifact constructor method
and the configuration parameters.
This commit is contained in:
HiPhish 2022-09-08 19:23:42 +02:00
parent 6d6fccf2f7
commit 7cf34ca065
8 changed files with 185 additions and 137 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
TODO.rst
View file

@ -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.

3
hssg-blog.asd
View file

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

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

@ -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))))))

151
src/blog/facade.lisp Normal file
View file

@ -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))))))

15
src/blog/package.lisp
View file

@ -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*))

8
src/blog/util.lisp
View file

@ -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))

9
src/hssg/package.lisp
View file

@ -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))

7
src/hssg/template.lisp
View file

@ -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))))