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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
;; SPDX-License-Identifier: GPL-3.0-only
;; SPDX-FileCopyrightText: Copyright (C) 2022-2023 by sterni
;; SPDX-FileCopyrightText: Copyright (C) 2006-2010 by Walter C. Pelissero
(in-package :mblog)
;; util
;; Taken from SCLF, written by Walter C. Pelissero
(defun pathname-as-directory (pathname)
"Converts PATHNAME to directory form and return it."
(setf pathname (pathname pathname))
(if (pathname-name pathname)
(make-pathname :directory (append (or (pathname-directory pathname)
'(:relative))
(list (file-namestring pathname)))
:name nil
:type nil
:defaults pathname)
pathname))
(defmacro with-overwrite-file ((&rest args) &body body)
"Like WITH-OPEN-FILE, but creates/supersedes the given file for writing."
`(with-open-file (,@args :direction :output
:if-exists :supersede
:if-does-not-exist :create)
,@body))
(defun redirect-stream (in out)
"Consume input stream IN and write all its content to output stream OUT.
The streams' element types need to match."
(let ((buf (make-array config:*general-buffer-size* :element-type (stream-element-type in))))
(loop for pos = (read-sequence buf in)
while (> pos 0)
do (write-sequence buf out :end pos))))
;; CSS
(defvar *style* "
header, main {
width: 100%;
max-width: 800px;
}
main img {
max-width: 100%;
}
a:link, a:visited {
color: blue;
}
")
;; Templating
(eval-when (:compile-toplevel :load-toplevel)
(setf (who:html-mode) :html5))
(defmacro render-page ((stream title &key root) &body body)
"Surround BODY with standard mblog document skeleton and render it to STREAM
using CL-WHO. If :ROOT is T, assume that the page is the top level index page.
Otherwise it is assumed to be one level below the index page."
`(who:with-html-output (,stream nil :prologue t)
(:html
(:head
(:meta :charset "utf-8")
(:meta :viewport "width=device-width")
(:title (who:esc ,title))
(:link :rel "stylesheet"
:type "text/css"
:href ,(concatenate 'string (if root "" "../") "style.css")))
(:body
(:header
(:nav
(:a :href ,(who:escape-string (if root "" "..")) "index")))
(:main ,@body)))))
;; Build Logic
(defun build-note-page (note note-dir)
"Convert NOTE to HTML and write it to index.html in NOTE-DIR alongside any
extra attachments NOTE contains."
(with-overwrite-file (html-stream (merge-pathnames "index.html" note-dir))
(render-page (html-stream (apple-note-subject note))
(:article
(apple-note-html-fragment note html-stream))))
(mime:do-parts (part note)
(unless (string= (mime:mime-id part)
(mime:mime-id (note:apple-note-text-part note)))
(let ((attachment-in (mime:mime-body-stream part))
(attachment-dst (merge-pathnames
(mime:mime-part-file-name part)
note-dir)))
(format *error-output* "Writing attachment ~A~%" attachment-dst)
(with-overwrite-file (attachment-out attachment-dst
:element-type
(stream-element-type attachment-in))
(redirect-stream attachment-in attachment-out)))))
(values))
(defun build-index-page (notes-list destination)
"Write an overview page linking all notes in NOTE-LIST in the given order to
DESTINATION. The notes are assumed to be in a sibling directory named like the
each note's UUID."
(with-overwrite-file (listing-stream destination)
(render-page (listing-stream "mblog" :root t)
(:h1 "mblog")
(:table
(dolist (note notes-list)
(who:htm
(:tr
(:td (:a :href (who:escape-string (apple-note-uuid note))
(who:esc (apple-note-subject note))))
(:td (who:esc
(klatre:format-dottime
(universal-to-timestamp (apple-note-time note)))))))))))
(values))
(defun build-mblog (notes-dir html-dir)
"Take MIME messages from maildir NOTES-DIR and build a complete mblog in HTML-DIR."
(setf notes-dir (pathname-as-directory notes-dir))
(setf html-dir (pathname-as-directory html-dir))
;; TODO(sterni): avoid rewriting if nothing was updated
;; TODO(sterni): clean up deleted things
;; TODO(sterni): atom feed
(let ((all-notes '()))
(dolist (message-path (maildir:list notes-dir))
(let* ((note (make-apple-note (mime:mime-message message-path)))
(note-dir (merge-pathnames (make-pathname
:directory
`(:relative ,(apple-note-uuid note)))
html-dir)))
(format *error-output* "Writing note message ~A to ~A~%"
message-path note-dir)
(ensure-directories-exist note-dir)
(build-note-page note note-dir)
(push note all-notes)))
;; reverse sort the entries by time for the index page
(setf all-notes (sort all-notes #'> :key #'apple-note-time))
(build-index-page all-notes (merge-pathnames "index.html" html-dir))
(with-overwrite-file (css-stream (merge-pathnames "style.css" html-dir))
(write-string *style* css-stream))
(values)))
|
