;;; 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 render-preview sort-posts 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." #<(article (@ (class "update-entry") (data-pagefind-body "1")) (h1 (@ (class "section-header")) ,(format #f "Blog :: ~a" (post-ref post 'title))) (div (@ (class "date-stamp")) (time (@ (datetime ,(date->string (post-date post) "~Y-~m-~d"))) ,(date->string (post-date post) "~B ~d, ~Y")) " » Tagged: " ,@(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") ".")) ,(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))) #<(article (@ (class "update-entry")) (header (div (@ (class "date-stamp")) (time (@ (datetime ,(date->string (post-date post) "~Y-~m-~d"))) ,(date->string (post-date post) "~B ~d, ~Y")) " » Tagged: " ,@(intersperse (map (lambda (tag) (hyperlink (tag-uri %tag-prefix tag) tag)) (post-ref post 'tags)) ", ")) (h3 (@ (class "title")) ,(hyperlink (or crosspost-uri local-uri) (post-ref post 'title)))) ;; TODO: Handle crossposts. ;; (p ;; ,(when crosspost-uri ;; (list " ↻ " (hyperlink local-uri "Crosspost"))) ;; " ❖ Tags: " ;; ) ,(first-paragraph post) (p ,(hyperlink (or crosspost-uri local-uri) "read more →"))))) ;; TODO: Should dynamically pull comments. (define (comments-section post) `(section (@ (class "comments-section") (aria-labelledby "comments-heading")) ,@(render-comment-view (fetch-comments (post-identifier post)) (fetch-webmentions (post-identifier post))) (div (@ (class "comment-form-module")) (h4 (@ (class "module-title")) "Leave a Comment") (form (@ (class "comment-form")) (div (@ (class "form-row")) (input (@ (type "text") (placeholder "Name") (required "") (aria-label "Name"))) (input (@ (type "text") (placeholder "Subject (Optional)") (aria-label "Subject")))) (div (@ (class "form-row")) (input (@ (type "url") (placeholder "Website (https://...)") (aria-label "Website URL")))) (textarea (@ (placeholder "Write your comment here...") (rows "4") (required "") (aria-label "Comment body"))))))) ;;; ;;; 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) ,(comments-section post) ,(script "section-folds.js") ,(script "comment-reaction.js"))) sxml->html)) ;;; ;;; Navigation based on post tags. ;;; (define %blog-prefix "/blog") ;; Subdirectory for post listings conditioned on post tags. (define %tag-prefix (string-append %blog-prefix "/tag")) (define* (sort-posts posts #:key (reverse? #f)) (sort posts (lambda (a b) ((if reverse? time=?) (date->time-monotonic (post-date a)) (date->time-monotonic (post-date b)))))) (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 posts #:reverse? #t) (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) "Blog" (string-append %blog-prefix "/index") #:enable-search #t) ;; Tag-based navigation. (list (all-tags posts)) (tags->pages posts))))