feat(users/sterni/mblog): implement mblog executable

This change finally sort of puts the parts together: We take a maildir,
render all its note messages as standalone HTML, extract the attachments
alongside and finally generate a global index page linking all notes.

The new executable and mnote-html are both contained in the same image
and we dispatch the right functionality based on argv[0].

Change-Id: I5a5bdbfaca79199f92e73ea4a2f070fa900d2bc4
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5113
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>

users/sterni/mblog/cli.lisp

@@ -1,18 +1,71 @@
-(in-package :mblog)
+(in-package :cli)
 (declaim (optimize (safety 3)))
 
-(defparameter +synopsis+ "mnote-html FILE [FILE [ ... ]]")
+;; TODO(sterni): nicer messages for various errors signaled?
 
-;; TODO(sterni): handle relevant conditions
+(defun partition-by (f seq)
-(defun main ()
+  "Split SEQ into two lists, returned as multiple values. The first list
-  (let* ((args (uiop:command-line-arguments))
+  contains all elements for which F returns T, the second one the remaining
-         (help-p (or (not args)
+  elements."
-                     (find-if (lambda (x)
+  (loop for x in seq
-                                (member x '("-h" "--help" "--usage")
+        if (funcall f x)
-                                        :test #'string=))
+          collecting x into yes
-                              args))))
+        else
-    (if help-p (format *error-output* "Usage: ~A~%" +synopsis+)
+          collecting x into no
+        finally (return (values yes no))))
+
+(defparameter +help+ '(("mnote-html" . "FILE [FILE [ ... ]]")
+                       ("mblog"      . "MAILDIR OUT")))
+
+(defun mnote-html (name flags &rest args)
+  "Convert all note mime messages given as ARGS to HTML fragments."
+  (declare (ignore name flags))
   (loop for arg in args
         do (note:apple-note-html-fragment
             (note:make-apple-note (mime:mime-message (pathname arg)))
-                *standard-output*)))))
+            *standard-output*)))
+
+(defun mblog (name flags maildir outdir)
+  "Read a MAILDIR and build an mblog in OUTDIR "
+  (declare (ignore name flags))
+  (build-mblog (pathname maildir) (pathname outdir)))
+
+(defun display-help (name flags &rest args)
+  "Print help message for current executable."
+  (declare (ignore args flags))
+  (format *error-output* "Usage: ~A ~A~%"
+          name
+          (or (cdr (assoc name +help+ :test #'string=))
+              (concatenate 'string "Unknown executable: " name))))
+
+(defun usage-error (name flags &rest args)
+  "Print help and exit with a non-zero exit code."
+  (format *error-output* "~A: usage error~%" name)
+  (display-help name args flags)
+  (uiop:quit 100))
+
+(defun main ()
+  "Dispatch to correct main function based on arguments and UIOP:ARGV0."
+  (multiple-value-bind (flags args)
+      (partition-by (lambda (x) (starts-with #\- x))
+                    (uiop:command-line-arguments))
+
+    (let ((prog-name (pathname-name (pathname (uiop:argv0))))
+          (help-requested-p (find-if (lambda (x)
+                                       (member x '("-h" "--help" "--usage")
+                                               :test #'string=))
+                                     args)))
+      (apply
+       (if help-requested-p
+           #'display-help
+           (cond
+             ((and (string= prog-name "mnote-html")
+                   (null flags))
+              #'mnote-html)
+             ((and (string= prog-name "mblog")
+                   (null flags)
+                   (= 2 (length args)))
+              #'mblog)
+             (t #'usage-error)))
+       (append (list prog-name flags)
+               args)))))

users/sterni/mblog/default.nix

@@ -1,13 +1,14 @@
 { depot, pkgs, ... }:
 
-depot.nix.buildLisp.program {
+(depot.nix.buildLisp.program {
-  name = "mnote-html";
+  name = "mblog";
 
   srcs = [
     ./packages.lisp
     ./maildir.lisp
     ./transformer.lisp
     ./note.lisp
+    ./mblog.lisp
     ./cli.lisp
   ];
 
@@ -16,19 +17,29 @@ depot.nix.buildLisp.program {
       sbcl = depot.nix.buildLisp.bundled "uiop";
       default = depot.nix.buildLisp.bundled "asdf";
     }
+    depot.lisp.klatre
     depot.third_party.lisp.alexandria
     depot.third_party.lisp.babel
     depot.third_party.lisp.closure-html
     depot.third_party.lisp.cl-date-time-parser
     depot.third_party.lisp.cl-who
+    depot.third_party.lisp.local-time
     depot.third_party.lisp.mime4cl
   ];
 
-  main = "mblog:main";
+  main = "cli:main";
 
   # due to sclf
   brokenOn = [
     "ccl"
     "ecl"
   ];
-}
+}).overrideAttrs (super: {
+  # The built binary dispatches based on argv[0]. Building two executables would
+  # waste a lot of space.
+  buildCommand = ''
+    ${super.buildCommand}
+
+    ln -s "$out/bin/mblog" "$out/bin/mnote-html"
+  '';
+})

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)))

users/sterni/mblog/packages.lisp

@@ -32,6 +32,20 @@
 (defpackage :mblog
   (:use
    :common-lisp
-   :uiop
+   :klatre
+   :who
+   :maildir
    :note)
+  (:export :build-mblog)
+  (:import-from :local-time :universal-to-timestamp)
+  (:import-from :sclf :pathname-as-directory)
+  (:shadowing-import-from :common-lisp :list))
+
+(defpackage :cli
+  (:use
+   :common-lisp
+   :uiop
+   :note
+   :mblog)
+  (:import-from :alexandria :starts-with)
   (:export :main))