140 lines
4.7 KiB
Common Lisp
140 lines
4.7 KiB
Common Lisp
(in-package :mblog)
|
|
|
|
;; util
|
|
|
|
(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))
|
|
|
|
(defvar *copy-buffer-size* 4096)
|
|
|
|
(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 *copy-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"))
|
|
(:style "a:link, a:visited { color: blue; }"))
|
|
(: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)))
|