1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
;;; 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 blogroll)
#:use-module (haunt artifact)
#:use-module (haunt html)
#: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-9)
#: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:
;;;
;;; Type for entries.
;;;
(define-record-type <entry>
(make-entry name uri tags comments)
entry?
(name entry-name)
(uri entry-uri)
(tags entry-tags)
(comments entry-comments))
(define entry
(match-lambda
((name uri tags) (make-entry name uri tags #f))
((name uri tags comments) (make-entry name uri tags comments))))
;;;
;;; Rendering.
;;;
(define* (render-preview name uri tags tag-prefix #:optional comments)
"Return an SHTML preview of an entry with the given parameters."
`(section
,@(cons*
`(h2 ,(hyperlink uri name))
`(p
,(intersperse
(map (lambda (tag)
(hyperlink (tag-uri tag-prefix tag) tag))
tags)
", "))
(or comments '()))))
(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 entry-tags))))
(define* (render-entries title prefix entries #:optional tag)
"Return an SHTML document listing ENTRIES in PREFIX, with a header of TITLE."
#<(main
(h1 ,(if tag
(format #f "~a :: Tagged \"~a\"" title tag)
title))
,(unless tag (render-tag-cloud prefix entries))
,(unless tag `(hr))
,@(map (lambda (entry)
(render-preview (entry-name entry)
(entry-uri entry)
(entry-tags entry)
prefix
(entry-comments entry)))
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
(serialized-artifact (string-append prefix "/index.html")
(theme #:title title
#:content (render-entries title prefix entries))
sxml->html)
(map (match-lambda
((tag . entries)
(serialized-artifact (tag-uri prefix tag)
(theme #:title title
#:content (render-entries title prefix entries tag))
sxml->html)))
(group-by-tag entries entry-tags))))
;;;
;;; Builder.
;;;
(define %blogroll
(list "Blogroll"
"/blogroll"
(map entry (primitive-load "data/blogroll.scm"))))
(define %bookmarks
(list "Bookmarks"
"/bookmark"
(map entry (primitive-load "data/bookmarks.scm"))))
(define (blogroll)
(lambda (site posts)
(flatten
(map (cut apply entries->pages <>)
(list %blogroll %bookmarks)))))
|
