1 files changed, 140 insertions, 0 deletions
diff --git a/users/sterni/mblog/mblog.lisp b/users/sterni/mblog/mblog.lisp
new file mode 100644
index 000000000000..1f971bc121d2
--- /dev/null
+++ b/users/sterni/mblog/mblog.lisp
@@ -0,0 +1,140 @@
+(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)))