1 files changed, 201 insertions, 0 deletions
diff --git a/jakob/builder/blog.scm b/jakob/builder/blog.scm
new file mode 100644
index 0000000..e03c3e2
--- /dev/null
+++ b/jakob/builder/blog.scm
@@ -0,0 +1,201 @@
+;;; Copyright © 2019 - 2020 Jakob L. Kreuze <zerodaysfordays@sdf.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 artifact)
+  #:use-module (haunt html)
+  #:use-module (haunt post)
+  #:use-module (haunt utils)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (jakob dynamic capabilities comment-form)
+  #:use-module (jakob theme)
+  #:use-module (jakob utils)
+  #:use-module (jakob utils pagination)
+  #:use-module (jakob utils sxml)
+  #:use-module (jakob utils tags)
+  #:use-module (jakob utils comments)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (web uri)
+  #:export (post-uri
+            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 (build-comment-url post)
+  (format #f "/api/comment-form/~a" (post-slug post)))
+
+(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 (tag-uri %tag-prefix tag) tag))
+                (post-ref post 'tags))
+           ", "))
+     ,(when (post-ref post 'crosspost)
+        `(p (strong "This is a summary ")
+            "of a post that was published elsewhere. "
+            "To read the full post, visit "
+            ,(hyperlink (post-ref post 'crosspost) "this link")
+            "."))
+     (div (@ (data-pagefind-body #t))
+       (article ,(post-sxml post))
+       (section
+        (@ (id "webmention"))
+        (h2 "Comments for this page")
+        (ul (@ (class "webmention-container"))
+            ,@(render-comment-view (fetch-comments (post-identifier post)) (fetch-webmentions (post-identifier post))))
+        (div (@ (id "comment-form-primary") (hidden #t))
+             ,(render-dynamic-comment-form (post-identifier post)))
+        (p (@ (id "comment-form-alt"))
+           "Click " ,(hyperlink (build-comment-url post) "here") " to write a comment on this post.")
+        (form
+         (@ (id "webmention-form")
+            (action "https://webmention.io/jakob.space/webmention")
+            (method "post"))
+         (label "Or, if you've written about this "
+                ,(hyperlink "https://indieweb.org/responses" "elsewhere")
+                ", you can send me a Webmention:")
+         (div (@ (id "webmention-input-group"))
+          (input (@ (name "source") (type "url") (placeholder "https://...")))
+          (input (@ (value "Send") (type "submit")))))
+        ,(script "section-folds.js")
+        ,(script "comment-reaction.js")))))
+
+(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 ,(date->string (post-date post) "~B ~d, ~Y")
+          ,(when crosspost-uri
+             (list " ↻ " (hyperlink local-uri "Crosspost")))
+          " ❖ Tags: "
+          ,@(intersperse
+             (map (lambda (tag)
+                    (hyperlink (tag-uri %tag-prefix tag) tag))
+                  (post-ref post 'tags))
+             ", "))
+       ,(first-paragraph post)
+       (p ,(hyperlink (or crosspost-uri local-uri) "read more →")))))
+
+
+;;;
+;;; Creation of permalink pages for individual lposts.
+;;;
+
+;; Subdirectory for permalink pages.
+(define %prefix "/blog")
+
+(define (post-identifier post)
+  "Return the 'slug' that identifies POST."
+  (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)))
+    slug))
+
+(define (post-uri post)
+  "Return the path of POST relative to the site's root."
+  (string-append %prefix "/" (post-identifier post) ".html"))
+
+(define (post->page post)
+  "Return a Haunt page for POST."
+  (define meta-tags (call-with-input-string (post-ref post 'meta-tags) read))
+  (define scripts (call-with-input-string (post-ref post 'scripts) read))
+  (serialized-artifact (post-uri post)
+                       (theme #:title (post-ref post 'title)
+                              #:description (description-from-post post)
+                              #:keywords (post-ref post 'tags)
+                              #:meta (if (not (eof-object? meta-tags)) meta-tags '())
+                              #:scripts (if (not (eof-object? scripts)) scripts '())
+                              #:content (render-article post))
+                       sxml->html))
+
+
+;;;
+;;; Navigation based on post tags.
+;;;
+
+;; Subdirectory for post listings conditioned on post tags.
+(define %tag-prefix "/blog/tag")
+
+(define (tags->pages posts)
+  "Return a list of pages for each tag used in POSTS, with said pages containing
+only the posts tagged with that tag."
+  (flat-map (match-lambda
+              ((tag . posts)
+               (items->pages render-preview posts
+                             (format #f "Posts tagged with \"~a\"" tag)
+                             (tag-uri %tag-prefix tag ""))))
+            (group-by-tag (sort posts (lambda (a b)
+                    (time<? (date->time-monotonic (post-date a)) (date->time-monotonic (post-date b))))) (cut post-ref <> 'tags))))
+
+(define (all-tags posts)
+  "Return a page summarizing tag usage across POSTS."
+  (define content
+    `((h1 "All Tags")
+      (ul (@ (id "tag-cloud"))
+          ,@(map (match-lambda
+                   ((tag count)
+                    (hyperlink (tag-uri %tag-prefix tag)
+                               `(li ,(format #f "~a (~a)" tag count)))))
+                 (count-tags posts (cut post-ref <> 'tags))))))
+  (serialized-artifact "tag.html"
+                       (theme #:title "All Tags"
+                              #:content content)
+                       sxml->html))
+
+
+;;;
+;;; 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
+     ;; Permalinks.
+     (map post->page posts)
+
+     ;; Main post navigation.
+     (items->pages render-preview (posts/reverse-chronological posts)
+                   "Recent Posts" "index"
+                   #:enable-search #t)
+
+     ;; Tag-based navigation.
+     (list (all-tags posts))
+     (tags->pages posts))))