Rewrite Haunt configuration.

8 files changed, 554 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)))))
diff --git a/haunt/jakob/builder/htaccess.scm b/haunt/jakob/builder/htaccess.scm
new file mode 100644
index 0000000..fd20eca
--- /dev/null
+++ b/haunt/jakob/builder/htaccess.scm
@@ -0,0 +1,35 @@
+;;; 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 htaccess)
+  #:use-module (haunt page)
+  #:export (htaccess))
+
+(define* (htaccess-writer contents #:optional (port (current-output-port)))
+  (display (string-join contents "\n") port)
+  (newline port))
+
+;; TODO: https://help.dreamhost.com/hc/en-us/articles/215747748-How-can-I-redirect-and-rewrite-my-URLs-with-an-htaccess-file-
+(define* (htaccess #:key handler-404)
+  "Create an .htaccess file at the site's root.
+
+HANDLER-404 specifies the file name of the page to display for a 404 not found."
+  (define contents
+    `(,(if handler-404
+           (format #f "ErrorDocument 404 ~a" handler-404))))
+
+  (lambda (site posts)
+    (make-page ".htaccess" contents htaccess-writer)))
diff --git a/haunt/jakob/builder/outbox.scm b/haunt/jakob/builder/outbox.scm
new file mode 100644
index 0000000..851ed88
--- /dev/null
+++ b/haunt/jakob/builder/outbox.scm
@@ -0,0 +1,51 @@
+;;; 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 outbox)
+  #:use-module (haunt page)
+  #:export (outbox))
+
+;;; Commentary:
+;;;
+;;; Implementation of a multi-page Webmention outbox. See
+;;; <https://webmention.net/> for details.
+;;;
+;;; Code:
+
+;; `((doctype "html")
+;;   (meta (@ (charset "utf-8")))
+;;   (title ,title)
+;;   (div (@ (class "h-entry"))
+;;        (img (@ (src ,profile-picture) (class "u-photo") (width "40")))
+;;        (a (@ (href ,profile-url) (class "u-url p-name")) ,profile-name))
+;;   (p "in reply to:" (a (@ (href ,target-url) (class "u-in-reply-to"))
+;;                        ,target-handle))
+;;   (p (@ (class "e-content")) ,content)
+;;   (p (a (@ (href "self") (class "u-url"))
+;;         (time (@ (datetime ,datetime) (class "dt-published"))
+;;               ,datetime-pretty))))
+
+;; (define* (htaccess #:key profile-url
+;;                    profile-name
+;;                    profile-picture
+;;                    (comment-dir "webmentions"))
+;;   "Create a multi-page Webmention outbox, reading comments from COMMENT-DIR."
+;;   (define contents
+;;     `(,(if handler-404
+;;            (format #f "ErrorDocument 404 ~a" handler-404))))
+
+;;   (lambda (site posts)
+;;     (make-page ".htaccess" contents htaccess-writer)))
diff --git a/haunt/jakob/builder/static-pages.scm b/haunt/jakob/builder/static-pages.scm
new file mode 100644
index 0000000..9089789
--- /dev/null
+++ b/haunt/jakob/builder/static-pages.scm
@@ -0,0 +1,48 @@
+;;; 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 static-pages)
+  #:use-module (haunt html)
+  #:use-module (haunt page)
+  #:use-module (ice-9 ftw)
+  #:use-module (jakob builder blog)
+  #:use-module (srfi srfi-1)
+  #:export (static-pages))
+
+(define* (static-pages)
+  (lambda (site posts)
+    (define enter? (const #t))
+
+    (define (leaf file-name stat memo)
+      (let* ((dest (if (string-suffix? ".sxml" file-name)
+                      (string-append (string-drop-right file-name
+                                                        (string-length ".sxml"))
+                                     ".html")
+                      file-name))
+             (name (first (string-split (basename dest) #\.)))
+             (sxml (primitive-load file-name))
+             ;; (contents (with-layout theme site name sxml))
+             (contents sxml)
+             )
+        (cons (make-page dest contents sxml->html) memo)))
+
+    (define (noop file-name stat result)
+      result)
+
+    (define (err file-name stat errno result)
+      (error "file processing failed with errno: " file-name errno))
+
+    (file-system-fold enter? leaf noop noop noop err '() "pages")))
diff --git a/haunt/jakob/reader/html-prime.scm b/haunt/jakob/reader/html-prime.scm
new file mode 100644
index 0000000..373edd5
--- /dev/null
+++ b/haunt/jakob/reader/html-prime.scm
@@ -0,0 +1,44 @@
+;;; 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/>.
+
+;;; Commentary:
+;;;
+;;; Temporary reader containing my changes to 'html-reader'. This module will
+;;; remain until Haunt sees another release and, thus, the fixes are available.
+;;;
+;;; Code:
+
+(define-module (jakob reader html-prime)
+  #:use-module (haunt post)
+  #:use-module (haunt reader)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:use-module (sxml simple)
+  #:export (html-reader-prime))
+
+(define (read-html-post-prime port)
+  (values (read-metadata-headers port)
+          (let loop ((ret '()))
+            (catch 'parser-error
+              (lambda ()
+                (match (xml->sxml port)
+                  (('*TOP* sxml) (loop (cons sxml ret)))))
+              (lambda (key . parameters)
+                (reverse ret))))))
+
+(define html-reader-prime
+  (make-reader (make-file-extension-matcher "html")
+               (cut call-with-input-file <> read-html-post-prime)))
diff --git a/haunt/jakob/theme.scm b/haunt/jakob/theme.scm
new file mode 100644
index 0000000..23d3929
--- /dev/null
+++ b/haunt/jakob/theme.scm
@@ -0,0 +1,101 @@
+;;; 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 theme)
+  #:use-module (ice-9 match)
+  #:use-module (jakob utils sxml)
+  #:export (theme))
+
+
+;;;
+;;; SHTML generation in the site's theme.
+;;;
+
+(define %stylesheets '("normalize.css" "fonts.css" "highlight.css" "style.css"))
+(define %link-rel '(("alternate" "/index.xml" "application/atom+xml")
+                    ("icon" "/static/image/favicon.ico" "image/vnd.microsoft.icon")
+                    ("me" "https://mastodon.sdf.org/@jakob")
+                    ("webmention" "https://webmention.io/jakob.space/webmention")
+                    ("pingback" "https://webmention.io/jakob.space/xmlrpc")
+                    ("pgpkey authn" "/gpg.txt")))
+(define %nav-bar-tabs '(("About" "/pages/about.html")
+                        ("Projects" "/pages/projects.html")
+                        ("Tags" "/tag.html")
+                        ("Atom" "/feed.xml")))
+
+(define %title "Jakob's Personal Webpage")
+
+(define %header
+  `(header
+    ,(hyperlink "/" (image "lambda.svg" "home"))
+    (nav (ul
+          ,@(map (lambda (tuple)
+                   `(li ,(apply hyperlink (reverse tuple))))
+                 %nav-bar-tabs)))))
+
+(define %footer
+  `(footer
+    (div
+     (p "© 2019 Jakob L. Kreuze")
+     ,(image "cc-by-sa-4.0.png"
+             "Creative Commons Attribution-ShareAlike 4.0 International (CC
+BY-SA 4.0) Logo"))
+    (p "Unless otherwise specified, the text and images on this site are free
+culture works available under the "
+       ,(hyperlink "https://creativecommons.org/licenses/by-sa/4.0/"
+                   "Creative Commons Attribution Share-Alike 4.0
+International")
+       " license.")
+    (p "This website is built with "
+       ,(hyperlink "http://haunt.dthompson.us/" "Haunt")
+       ", a static site generator written in "
+       ,(hyperlink "https://gnu.org/software/guile" "Guile Scheme")
+       ".")))
+
+(define* (theme #:key
+                (title '())
+                (description "")
+                (keywords '())
+                (content '(div "")))
+  "Return an SHTML document using the website's theme."
+  `((doctype "html")
+    (html
+     (@ (lang "en"))
+
+     (head
+      ,(if (null? title)
+           `(title %title)
+           `(title ,(string-join (list title %title) " — ")))
+
+      (meta (@ (charset "utf-8")))
+      (meta (@ (name "keywords")
+               (content ,(string-join keywords ", "))))
+      (meta (@ (name "description")
+               (content ,description)))
+      (meta (@ (name "viewport")
+               (content "width=device-width, initial-scale=1.0")))
+
+      ,@(map (lambda (file-name) (stylesheet file-name)) %stylesheets)
+
+      ,@(map (match-lambda
+              ((rel href) `(link (@ (rel ,rel) (href ,href))))
+              ((rel href type) `(link (@ (rel ,rel) (href ,href) (type ,type)))))
+             %link-rel))
+
+     (body
+      ,%header
+      ,content
+      ,%footer))))
diff --git a/haunt/jakob/utils.scm b/haunt/jakob/utils.scm
new file mode 100644
index 0000000..33f8f93
--- /dev/null
+++ b/haunt/jakob/utils.scm
@@ -0,0 +1,59 @@
+;;; 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 utils)
+  #:use-module (haunt post)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (maybe-cons*
+            maybe-list
+            date->string*
+            intersperse
+            first-paragraph))
+
+(define (maybe-list . args)
+  "Create a list of all ARGS that are neither #f nor unspecified."
+  (remove (lambda (element)
+            (or (not element) (unspecified? element)))
+          args))
+
+(define (maybe-cons* . args)
+  "Cons all ARGS that are neither #f nor unspecified."
+  (apply cons* (apply maybe-list args)))
+
+(define (date->string* date)
+  "Convert DATE to human readable string."
+  (date->string date "~a ~d ~B ~Y"))
+
+(define (intersperse lst delim)
+  "Return the elements of LST delimited by DELIM, such that the resultant list
+is of an odd length and every second element is DELIM."
+  (if (<= (length lst) 1)
+      lst
+      (cons* (car lst)
+             delim
+             (intersperse (cdr lst) delim))))
+
+(define (first-paragraph post)
+  (let loop ((sxml (post-sxml post))
+             (result '()))
+    (match sxml
+      (() (reverse result))
+      ((or (('p ...) _ ...) (paragraph _ ...))
+       (reverse (cons paragraph result)))
+      ((head . tail)
+       (loop tail (cons head result))))))
+
diff --git a/haunt/jakob/utils/sxml.scm b/haunt/jakob/utils/sxml.scm
new file mode 100644
index 0000000..c4ce33d
--- /dev/null
+++ b/haunt/jakob/utils/sxml.scm
@@ -0,0 +1,38 @@
+;;; 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/>.
+
+;;; Commentary:
+;;;
+;;; A number of utility procedure to aid in writing SXML by hand.
+;;;
+;;; Code:
+
+(define-module (jakob utils sxml)
+  #:export (hyperlink
+            image
+            stylesheet))
+
+(define (hyperlink target text)
+  `(a (@ (href ,target)) ,text))
+
+(define* (image filename #:optional description)
+  (let ((src (string-append "/static/image/" filename)))
+    (if description
+        `(img (@ (src ,src) (alt ,description) (title ,description)))
+        `(img (@ (src ,src))))))
+
+(define (stylesheet file-name)
+  `(link (@ (rel "stylesheet") (href ,(format #f "/static/css/~a" file-name)))))