Rewrite Haunt configuration.

1 files changed, 178 insertions, 0 deletions

diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
new file mode 100644
index 0000000..2ed99e3
--- /dev/null
+++ b/haunt/jakob/builder/blog.scm
@@ -0,0 +1,178 @@
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (jakob builder blog)
+  #:use-module (haunt html)
+  #:use-module (haunt page)
+  #:use-module (haunt post)
+  #:use-module (haunt utils)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (jakob theme)
+  #:use-module (jakob utils)
+  #:use-module (jakob utils sxml)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:export (blog))
+
+;;; Commentary:
+;;;
+;;; In favor of greater flexibility, Haunt's default 'blog' builder was not used
+;;; for this site. This modules implements a similar builder, 'blog', with
+;;; pagination and support for tag navigation.
+;;;
+;;; Code:
+
+
+;;;
+;;; Rendering.
+;;;
+
+(define (render-article post)
+  "Return the SHTML for POST's contents."
+  `(main
+    (h1 ,(post-ref post 'title))
+    (p ,(date->string (post-date post) "~B ~d, ~Y")
+       " ❖ "
+       "Tags: "
+       ,@(intersperse
+          (map (lambda (tag)
+                 (hyperlink (format #f "/tag-~a.html" tag) tag))
+               (post-ref post 'tags))
+          ", "))
+    (article
+     ,(post-sxml post))))
+
+(define (render-preview post)
+  "Return the SHTML for a preview of POST."
+  (let ((crosspost-uri (post-ref post 'crosspost))
+        (local-uri (post-uri post)))
+    `(section
+      (h2 ,(hyperlink (or crosspost-uri local-uri) (post-ref post 'title)))
+      (p ,@(maybe-cons*
+            (date->string (post-date post) "~B ~d, ~Y")
+            (when crosspost-uri
+              (list " ⮀ " (hyperlink local-uri "Crosspost")))
+            " ❖ Tags: "
+            (intersperse
+             (map (lambda (tag)
+                    (hyperlink (format #f "/tag-~a.html" tag) tag))
+                  (post-ref post 'tags))
+             ", ")))
+      (p ,(first-paragraph post))
+      ,(hyperlink (or crosspost-uri local-uri) "read more 🢩"))))
+
+(define (render-listing posts title previous-page next-page)
+  "Return SHTML presenting previews for POSTS, with the header TITLE and links
+to PREVIOUS-PAGE and NEXT-PAGE."
+  `((h1 ,title)
+    ,@(map render-preview posts)
+    (nav
+     (@ (id "pagination"))
+     ,@(maybe-list
+        (when previous-page
+          (hyperlink previous-page "🢨 Previous Page"))
+        (when next-page
+          (hyperlink next-page "Next Page 🢩"))))))
+
+
+;;;
+;;; Creation of permalink pages for individual posts.
+;;;
+
+;; Subdirectory for permalink pages.
+(define %prefix "blog")
+
+(define (post-uri post)
+  "Return the path of POST relative to the site's base directory."
+  (let* ((file-name (post-file-name post))
+         (splice-start (1+ (string-rindex file-name (cut char=? <> #\/))))
+         (splice-end (string-rindex file-name (cut char=? <> #\.)))
+         (slug (substring file-name splice-start splice-end)))
+    (string-append %prefix "/" slug ".html")))
+
+(define (post->page post)
+  "Return a Haunt page for POST."
+  (make-page (post-uri post)
+             (theme #:title (post-ref post 'title)
+                    #:description (first-paragraph post)
+                    #:keywords (post-ref post 'tags)
+                    #:content (render-article post))
+             sxml->html))
+
+
+;;;
+;;; Implementation of pagination.
+;;;
+
+(define %posts-per-page 10)
+
+(define* (paginate posts #:optional (posts-per-page %posts-per-page))
+  "Partition POSTS into list of no more than POSTS-PER-PAGE posts, of the
+form (index, posts)."
+  (let loop ((index 1)
+             (lst posts)
+             (result '()))
+    (if (null? lst)
+        result
+        (let ((how-many (min %posts-per-page (length lst))))
+          (loop (1+ index)
+                (drop lst how-many)
+                (cons (list index (take lst how-many))
+                      result))))))
+
+(define (post-list->pages base-title base-file-name posts)
+  "Return a list of Haunt pages for POST, with headers containing BASE-TITLE and
+output file names beginning with BASE-FILE-NAME."
+  (define (index->file-name index)
+    (if (= index 1)
+        (format #f "~a.html" base-file-name)
+        (format #f "~a-~a.html" base-file-name index)))
+  (map (match-lambda
+         ((index subset)
+          (let ((title (if (= index 1)
+                           base-title
+                           (format #f "~a — Page ~a" base-title index)))
+                (previous-page (if (>= (1- index) 1)
+                                   (index->file-name (1- index))
+                                   #f))
+                (next-page (if (<= (1+ index) (ceiling/ (length posts)
+                                                        %posts-per-page))
+                               (index->file-name (1+ index))
+                               #f)))
+            (make-page (index->file-name index)
+                       (theme #:title title
+                              #:content
+                              (render-listing subset title
+                                              previous-page next-page))
+                       sxml->html))))
+       (paginate posts)))
+
+
+;;;
+;;; Builder.
+;;;
+
+(define (blog)
+  "Return a Haunt build procedure to create permalinks and post listings for all
+of the 'post' objects associated with the site."
+  (lambda (site posts)
+    (append
+     (map post->page posts)
+     (post-list->pages
+      "Recent Posts" "index"
+      (posts/reverse-chronological posts)))))