Implement a blogroll

4 files changed, 184 insertions, 23 deletions

diff --git a/haunt/haunt.scm b/haunt/haunt.scm
index c5ef247..2454cd9 100644
--- a/haunt/haunt.scm
+++ b/haunt/haunt.scm
@@ -19,6 +19,7 @@
              (haunt post)
              (haunt site)
              (jakob builder blog)
+             (jakob builder blogroll)
              (jakob builder htaccess)
              (jakob builder static-pages)
              (jakob reader html-prime)
@@ -44,6 +45,7 @@
       #:builders
       (list (atom-feed)
             (blog)
+            (blogroll)
             (htaccess #:handler-404 "pages/404.html")
             (static-pages)
             (static-directory "static")))
diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
index 5a178d7..f8a8d6e 100644
--- a/haunt/jakob/builder/blog.scm
+++ b/haunt/jakob/builder/blog.scm
@@ -24,6 +24,7 @@
   #:use-module (jakob theme)
   #:use-module (jakob utils)
   #:use-module (jakob utils sxml)
+  #:use-module (jakob utils tags)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -51,7 +52,7 @@
        "Tags: "
        ,@(intersperse
           (map (lambda (tag)
-                 (hyperlink (tag-uri tag) tag))
+                 (hyperlink (tag-uri %tag-prefix tag) tag))
                (post-ref post 'tags))
           ", "))
     (article
@@ -70,7 +71,7 @@
             " ❖ Tags: "
             (intersperse
              (map (lambda (tag)
-                    (hyperlink (tag-uri tag) tag))
+                    (hyperlink (tag-uri %tag-prefix tag) tag))
                   (post-ref post 'tags))
              ", ")))
       (p ,(first-paragraph post))
@@ -95,10 +96,10 @@ to PREVIOUS-PAGE and NEXT-PAGE."
 ;;;
 
 ;; Subdirectory for permalink pages.
-(define %prefix "blog")
+(define %prefix "/blog")
 
 (define (post-uri post)
-  "Return the path of POST relative to the site's base directory."
+  "Return the path of POST relative to the site's root."
   (let* ((file-name (post-file-name post))
          (splice-start (1+ (string-rindex file-name (cut char=? <> #\/))))
          (splice-end (string-rindex file-name (cut char=? <> #\.)))
@@ -168,12 +169,7 @@ and output file names beginning with BASE-FILE-NAME."
 ;;;
 
 ;; Subdirectory for post listings conditioned on post tags.
-(define %tag-prefix "tag")
-
-(define* (tag-uri tag #:optional (extension ".html"))
-  "Return the URI relative to the site's root of a page listing posts tagged
-with TAG."
-  (string-append %tag-prefix "/" tag extension))
+(define %tag-prefix "/blog/tag")
 
 (define (tags->pages posts)
   "Return a list of pages for each tag used in POSTS, with said pages containing
@@ -181,18 +177,9 @@ only the posts tagged with that tag."
   (flat-map (match-lambda
               ((tag . posts)
                (post-list->pages (format #f "Posts tagged as \"~a\"" tag)
-                                 (tag-uri tag "")
+                                 (tag-uri %tag-prefix tag "")
                                  posts)))
-            (posts/group-by-tag posts)))
-
-(define (count-tags posts)
-  "Return lists of the form (tag-name count) summarizing tag usage across POSTS,
-ordered such that tags with greater usage are at the beginning of the list, and
-tags with less usage are at the end of the list."
-  (sort (map (lambda (tag)
-               (list (car tag) (length (cdr tag))))
-             (posts/group-by-tag posts))
-        (lambda (a b) (> (cadr a) (cadr b)))))
+            (group-by-tag posts (cut post-ref <> 'tags))))
 
 (define (all-tags posts)
   "Return a page summarizing tag usage across POSTS."
@@ -201,9 +188,9 @@ tags with less usage are at the end of the list."
       (ul (@ (id "tag-cloud"))
           ,@(map (match-lambda
                    ((tag count)
-                    (hyperlink (tag-uri tag)
+                    (hyperlink (tag-uri %tag-prefix tag)
                                `(li ,(format #f "~a (~a)" tag count)))))
-                 (count-tags posts)))))
+                 (count-tags posts (cut post-ref <> 'tags))))))
   (make-page "tag.html"
              (theme #:title "All Tags"
                     #:content content)
diff --git a/haunt/jakob/builder/blogroll.scm b/haunt/jakob/builder/blogroll.scm
new file mode 100644
index 0000000..70ab1f9
--- /dev/null
+++ b/haunt/jakob/builder/blogroll.scm
@@ -0,0 +1,115 @@
+;;; 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 blogroll)
+  #:use-module (haunt html)
+  #:use-module (haunt page)
+  #:use-module (haunt utils)
+  #:use-module (ice-9 match)
+  #:use-module (jakob theme)
+  #:use-module (jakob utils)
+  #:use-module (jakob utils sxml)
+  #:use-module (jakob utils tags)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (blogroll))
+
+;;; Commentary:
+;;;
+;;; This module manages pages for listing the blogs that I personally follow and
+;;; articles that I enjoyed reading.
+;;;
+;;; Code:
+
+
+;;;
+;;; Page creation.
+;;;
+
+(define (render-preview name uri tags tag-prefix)
+  "Return an SHTML preview of an entry with the given parameters."
+  `(section
+    (h2 ,(hyperlink uri name))
+    (p
+     ,(intersperse
+       (map (lambda (tag)
+              (hyperlink (tag-uri tag-prefix tag) tag))
+            tags)
+       ", "))))
+
+(define (render-tag-cloud prefix entries)
+  "Return SHTML listing the tags of ENTRIES in PREFIX with the number of times
+each tag is used."
+  `(ul (@ (id "tag-cloud"))
+       ,@(map (match-lambda
+                ((tag count)
+                 (hyperlink (tag-uri prefix tag)
+                            `(li ,(format #f "~a (~a)" tag count)))))
+              (count-tags entries third))))
+
+(define* (render-entries title prefix entries #:optional tag)
+  "Return an SHTML document listing ENTRIES in PREFIX, with a header of TITLE."
+  `(main
+    ,@(maybe-cons*
+       `(h1 ,(if tag
+                 (format #f "~a - Tagged as ~a" title tag)
+                 title))
+       (unless tag
+         (render-tag-cloud prefix entries))
+       (unless tag
+         `(hr))
+       (map (match-lambda
+              ((name uri tags)
+               (render-preview name uri tags prefix)))
+            entries))))
+
+(define (entries->pages title prefix entries)
+  "Return a page listing ENTRIES in PREFIX with a header of TITLE, as well as
+pages for each of the tags used in ENTRIES."
+  (cons
+   (make-page (string-append prefix "/index.html")
+              (theme #:title title
+                     #:content (render-entries title prefix entries))
+              sxml->html)
+   (map (match-lambda
+          ((tag . entries)
+           (make-page (tag-uri prefix tag)
+                      (theme #:title title
+                             #:content (render-entries title prefix entries tag))
+                      sxml->html)))
+        (group-by-tag entries third))))
+
+
+
+;;;
+;;; Builder.
+;;;
+
+(define %blogroll
+  (list "Blogroll"
+        "/blogroll"
+        (primitive-load "data/blogroll.scm")))
+
+(define %bookmarks
+  (list "Bookmarks"
+        "/bookmark"
+        (primitive-load "data/bookmarks.scm")))
+
+(define (blogroll)
+  (lambda (site posts)
+    (flatten
+     (map (cut apply entries->pages <>)
+          (list %blogroll %bookmarks)))))
diff --git a/haunt/jakob/utils/tags.scm b/haunt/jakob/utils/tags.scm
new file mode 100644
index 0000000..87bec60
--- /dev/null
+++ b/haunt/jakob/utils/tags.scm
@@ -0,0 +1,57 @@
+;;; 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:
+;;;
+;;; Common procedures for tag-based navigation.
+;;;
+;;; Code:
+
+(define-module (jakob utils tags)
+  #:use-module (srfi srfi-1)
+  #:export (group-by-tag
+            count-tags
+            tag-uri))
+
+(define (group-by-tag items accessor)
+  "Return lists of the form (tag items) for each tag used in ITEMS. ACCESSOR is
+a procedure that takes a single item as an argument and returns its tags."
+  (let ((table (make-hash-table)))
+    (for-each (lambda (item)
+                (let ((tags (accessor item)))
+                  (for-each (lambda (tag)
+                              (let ((current (hash-ref table tag)))
+                                (if current
+                                    (hash-set! table tag (cons item current))
+                                    (hash-set! table tag (list item)))))
+                            tags)))
+              items)
+    (hash-fold alist-cons '() table)))
+
+(define (count-tags items accessor)
+  "Return lists of the form (tag-name count) summarizing tag usage across ENTRIES,
+ordered such that tags with greater usage are at the beginning of the list, and
+tags with less usage are at the end of the list. ACCESSOR is a procedure that
+takes a single item as an argument and returns its tags."
+  (sort (map (lambda (tag)
+               (list (car tag) (length (cdr tag))))
+             (group-by-tag items accessor))
+        (lambda (a b) (> (cadr a) (cadr b)))))
+
+(define* (tag-uri prefix tag #:optional (extension ".html"))
+  "Return a URI relative to the site's root for a page listing entries in PREFIX
+that are tagged with TAG."
+  (string-append prefix "/tag/" tag extension))