;;; Copyright © 2019 - 2020 Jakob L. Kreuze ;;; ;;; 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 ;;; . (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 "/apps/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) (timetime-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))))