From ca8b8817c503209c554b0d473b188c7591fb44ed Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 11 Apr 2021 22:11:21 +0200
Subject: website: Add support for a blog.

* website/haunt.scm (post-url, post->sxml, page->sxml)
(post->page): New procedures.
(%theme): New variable.
<top level>: Add blog post pages.
* website/static/css/main.css (.post-about): Tweak margin.
---
 website/haunt.scm           | 97 +++++++++++++++++++++++++++++++++++++++++++--
 website/static/css/main.css |  2 +-
 2 files changed, 95 insertions(+), 4 deletions(-)

(limited to 'website')

diff --git a/website/haunt.scm b/website/haunt.scm
index f4c95aa..b67b668 100644
--- a/website/haunt.scm
+++ b/website/haunt.scm
@@ -19,10 +19,15 @@
              (haunt site)
              (haunt page)
              (haunt html)
+             (haunt post)
              (haunt builder assets)
+             (haunt builder blog)
+             (haunt builder atom)
              (haunt reader)
              (haunt reader commonmark)
-             (srfi srfi-71)
+             (srfi srfi-19)                       ;dates
+             (srfi srfi-26)                       ;cut
+             (srfi srfi-71)                       ;multiple-value let
              (ice-9 match))
 
 (define %cwd
@@ -152,11 +157,97 @@ representation."
                        "social-contract.md")))
 
 
+;;;
+;;; Blog.
+;;;
+
+(define (post-url post site)
+  "Return the URL of POST, a Haunt blog post, for SITE."
+  (let ((date (post-date post)))
+    (base-url "/en/blog/"
+              (number->string (date-year date))
+              "/"
+              (string-pad (number->string (date-month date))
+                          2 #\0)
+
+              ;; There's an implicit "/index.html" here.
+              "/" (site-post-slug site post))))
+
+(define* (post->sxml post #:key post-uri summarize?)
+  "Return the SXML for POST."
+  (define post-body*
+    ;; (if summarize?
+    ;;     (cut summarize-post <> post-uri)
+    ;;     post-sxml*)
+    post-sxml
+    )
+
+  `(div (@ (class "post"))
+        (h1 (@ (class "title"))
+            ,(if post-uri
+                 `(a (@ (href ,post-uri))
+                     ,(post-ref post 'title))
+                 (post-ref post 'title)))
+        (div (@ (class "post-about"))
+             ,(post-ref post 'author)
+             " — " ,(date->string (post-date post) "~B ~e, ~Y"))
+        (hr)
+        (div (@ (class "post-body"))
+             ,(post-body* post))))
+
+(define (page->sxml site title posts prefix)
+  "Return the SXML for the news page of SITE, containing POSTS."
+  `((div (@ (class "header"))
+         (div (@ (class "post-list"))
+              ,@(map (lambda (post)
+                       (post->sxml post #:post-uri (post-url post site)
+                                   #:summarize? #t))
+                     posts)))))
+
+(define (post->page post site)
+  (make-page (string-append (post-url post site) "/index.html")
+             (render-post %theme site post)
+             sxml->html))
+
+(define %theme
+  ;; Theme for the rendering of the news pages.
+  (theme #:name "The GNU Assembly"
+         #:layout (lambda (site title body)
+                    (base-layout body
+                                 #:title
+                                 (string-append "The GNU Assembly — "
+                                                title)))
+         #:post-template post->sxml
+         #:collection-template page->sxml))
+
+
 (site #:title "The GNU Assembly"
       #:domain "gnu.tools"
       #:default-metadata
       '((author . "The GNU Assembly")
         (email  . "assembly@lists.gnu.tools"))
       #:readers (list commonmark-reader)
-      #:builders (cons (static-directory "static")
-                       (static-pages)))
+      #:builders (append (list (static-directory "static"))
+                         (static-pages)
+
+                         ;; Blog posts.
+                         (list (lambda (site posts)
+                                 ;; Pages for each post.
+                                 (map (cut post->page <> site) posts))
+
+                               (lambda (site posts)
+                                 ;; The main collection.
+                                 (make-page
+                                  "/en/blog/index.html"
+                                  (render-collection
+                                   %theme site
+                                   "The GNU Assembly — Blog" ;title
+                                   (posts/reverse-chronological posts)
+                                   "/en/blog")
+                                  sxml->html))
+
+                               ;; Apparently the <link> tags of Atom entries
+                               ;; must be absolute URLs, hence this
+                               ;; #:blog-prefix.
+                               (atom-feed #:file-name "en/blog/feed.xml"
+                                          #:blog-prefix "https://gnu.tools/en/blog"))))
diff --git a/website/static/css/main.css b/website/static/css/main.css
index 8e2d1a0..6f2eeaa 100644
--- a/website/static/css/main.css
+++ b/website/static/css/main.css
@@ -209,7 +209,7 @@ hr {
 .post-about {
     color: #4D4D4D;
     font-size: 0.9em;
-    margin-top: -3em;
+    margin-top: -2em;
 }
 
 #menubar ul { display: inline-block; padding: 0px; margin: 0px; }
-- 
cgit v1.2.1