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
|
(define-module (theme)
#:use-module (haunt html)
#:use-module (haunt site)
#:use-module (haunt post)
#:use-module (haunt artifact)
#:use-module (haunt builder blog)
#:use-module (sxml xpath)
#:export (hwebs-theme-blog
hwebs-theme-now
flat-page-template
game-page))
(define (post-uri post site prefix)
(string-append "/" (or prefix "") "/"
(site-post-slug site post) ".html"))
;;
;; BLOG
;;
(define layout
(lambda (site title body)
`((doctype "html")
(html
(@ (lang "en"))
(head
(meta (@ (http-equiv "Content-Type")
(content "text/html")
(charset "utf-8")))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1.0")))
(meta (@ (name "color-scheme")
(content "light dark")))
(link (@ (rel "stylesheet")
(href "/style.css")))
(link (@ (rel "icon")
(href "data:,")))
(title ,(string-append title " — " (site-title site))))
(body
(header (span ,(assq-ref (site-default-metadata site) 'author))
(nav (ul (li (a (@ (href "/")) "Home"))
(li (details (summary "Pages")
(ul
(li (a (@ (href "/now")) "Now"))
(li (a (@ (href "/blog")) "Blog"))
(li (a (@ (href "/games.html")) "Games"))
))))))
(main
,body))))))
(define hwebs-theme-blog
(theme #:name "hwebs"
#:layout layout
#:post-template
(lambda (post)
;; TODO fill in datetime correctly
;; TODO add <author>? (as hidden?)
`((article (h1 ,(post-title post))
(time ,(date->string*(post-date post)))
,(post-sxml post))))
#:collection-template
(lambda (site title posts prefix)
`((h1 ,title)
(p (a (@ (href "/blog/feed.xml")) "Atom feed."))
(ul
,@(map (lambda (post)
`(li (a (@ (href ,(post-uri post site prefix)))
,(post-ref post 'title)
" — "
,(date->string* (post-date post)))))
posts))))))
(define (flat-page-template site metadata body)
((theme-layout hwebs-theme-blog) site (assq-ref metadata 'title) `((h1 ,(assq-ref metadata 'title)) ,body)))
;;
;; NOW
;;
(define (rss-items-template items)
`(ul
,@(map (lambda (item)
`(li ,item))
items)))
(define (rss-items post)
((sxpath '(rss channel item title *text*)) (post-sxml post)))
(define hwebs-theme-now
(theme #:name "hwebs-now"
#:layout layout
#:post-template
(compose rss-items-template rss-items)
#:collection-template
(lambda (site title posts prefix)
`((h1 ,title)
(p "My implementation of the "
(a (@ (href "https://nownownow.com/about")) "\"now page\" concept by Derek Sivers")
".")
,@(map (lambda (post)
(define items
(rss-items post))
(if (member "feed" (post-tags post))
;; TODO use dates from the feed for these as well? - most recent pubDate?
;; TODO combine structure between the two types
`(section (h2 ,(post-ref post 'title))
,(rss-items-template
;; not optimal, btw
(list-head items (min 5 (length items))))
;; TODO only show if there are more entries than max?
(p (a (@ (href ,(post-uri post site prefix))) "See more.")))
`(section (h2 ,(post-ref post 'title))
;; TODO fill in datetime correctly
((header "updated " (time ,(date->string*(post-date post))))
,(post-sxml post)))))
posts)))))
;;; GAMES
(define (static-page title file-name body)
(lambda (site posts)
(serialized-artifact file-name
;; TODO: simplify this
(with-layout hwebs-theme-now site title body)
sxml->html)))
(define (game-page name js file-name)
(define body
`((h1 ,name)
(script (@ (src ,js)))
(div (@ (id "app")))))
(static-page name (string-append "games/" file-name) body))
|
