about summary refs log tree commit diff
path: root/users/sterni/mblog
diff options
context:
space:
mode:
Diffstat (limited to 'users/sterni/mblog')
-rw-r--r--users/sterni/mblog/.gitignore5
-rw-r--r--users/sterni/mblog/cli.lisp71
-rw-r--r--users/sterni/mblog/default.nix44
-rw-r--r--users/sterni/mblog/maildir.lisp17
-rw-r--r--users/sterni/mblog/mblog.lisp140
-rw-r--r--users/sterni/mblog/note.lisp118
-rw-r--r--users/sterni/mblog/packages.lisp49
-rw-r--r--users/sterni/mblog/transformer.lisp127
8 files changed, 571 insertions, 0 deletions
diff --git a/users/sterni/mblog/.gitignore b/users/sterni/mblog/.gitignore
new file mode 100644
index 000000000000..ae957fcad0dc
--- /dev/null
+++ b/users/sterni/mblog/.gitignore
@@ -0,0 +1,5 @@
+# local test data
+test-msg
+
+# sly C-c C-k
+*.fasl
diff --git a/users/sterni/mblog/cli.lisp b/users/sterni/mblog/cli.lisp
new file mode 100644
index 000000000000..9bc0681df0f5
--- /dev/null
+++ b/users/sterni/mblog/cli.lisp
@@ -0,0 +1,71 @@
+(in-package :cli)
+(declaim (optimize (safety 3)))
+
+;; TODO(sterni): nicer messages for various errors signaled?
+
+(defun partition-by (f seq)
+  "Split SEQ into two lists, returned as multiple values. The first list
+  contains all elements for which F returns T, the second one the remaining
+  elements."
+  (loop for x in seq
+        if (funcall f x)
+          collecting x into yes
+        else
+          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*)))
+
+(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)))))
diff --git a/users/sterni/mblog/default.nix b/users/sterni/mblog/default.nix
new file mode 100644
index 000000000000..607d198930d1
--- /dev/null
+++ b/users/sterni/mblog/default.nix
@@ -0,0 +1,44 @@
+{ depot, pkgs, ... }:
+
+(depot.nix.buildLisp.program {
+  name = "mblog";
+
+  srcs = [
+    ./packages.lisp
+    ./maildir.lisp
+    ./transformer.lisp
+    ./note.lisp
+    ./mblog.lisp
+    ./cli.lisp
+  ];
+
+  deps = [
+    {
+      sbcl = depot.nix.buildLisp.bundled "uiop";
+      default = depot.nix.buildLisp.bundled "asdf";
+    }
+    depot.lisp.klatre
+    depot.third_party.lisp.alexandria
+    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 = "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"
+  '';
+})
diff --git a/users/sterni/mblog/maildir.lisp b/users/sterni/mblog/maildir.lisp
new file mode 100644
index 000000000000..aca014203e29
--- /dev/null
+++ b/users/sterni/mblog/maildir.lisp
@@ -0,0 +1,17 @@
+(in-package :maildir)
+(declaim (optimize (safety 3)))
+
+(defun list (dir)
+  "Returns a list of pathnames to messages in a maildir. The messages are
+  returned in no guaranteed order. Note that this function doesn't fully
+  implement the behavior prescribed by maildir(5): It only looks at `cur`
+  and `new` and won't clean up `tmp` nor move files from `new` to `cur`,
+  since it is strictly read-only."
+  (flet ((subdir-contents (subdir)
+           (directory
+            (merge-pathnames
+             (make-pathname :directory `(:relative ,subdir)
+                            :name :wild :type :wild)
+             dir))))
+    (mapcan #'subdir-contents '("cur" "new"))))
+
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)))
diff --git a/users/sterni/mblog/note.lisp b/users/sterni/mblog/note.lisp
new file mode 100644
index 000000000000..45be0f4e88a8
--- /dev/null
+++ b/users/sterni/mblog/note.lisp
@@ -0,0 +1,118 @@
+(in-package :note)
+(declaim (optimize (safety 3)))
+
+;;; util
+
+;; TODO(sterni): merge this with mblog::*copy-buffer-size*
+(defvar *copy-buffer-size* 4096)
+
+(defun html-escape-stream (in out)
+  "Escape characters read from stream IN and write them to
+  stream OUT escaped using WHO:ESCAPE-STRING-MINIMAL."
+  (let ((buf (make-string *copy-buffer-size*)))
+    (loop for len = (read-sequence buf in)
+          while (> len 0)
+          do (write-string (who:escape-string-minimal (subseq buf 0 len)) out))))
+
+(defun cid-header-value (cid)
+  "Takes a Content-ID as present in Apple Notes' <object> tags and properly
+  surrounds them with angle brackets for a MIME header"
+  (concatenate 'string "<" cid ">"))
+
+(defun find-mime-message-date (message)
+  (when-let ((date-string (car (mime:mime-message-header-values "Date" message))))
+    (date-time-parser:parse-date-time date-string)))
+
+;;; main implementation
+
+(defun apple-note-mime-subtype-p (x)
+  (member x '("plain" "html") :test #'string-equal))
+
+(deftype apple-note-mime-subtype ()
+  '(satisfies apple-note-mime-subtype-p))
+
+(defclass apple-note (mime:mime-message)
+  ((text-part
+    :type mime:mime-text
+    :initarg :text-part
+    :reader apple-note-text-part)
+   (subject
+    :type string
+    :initarg :subject
+    :reader apple-note-subject)
+   (uuid
+    :type string
+    :initarg :uuid
+    :reader apple-note-uuid)
+   (time
+    :type integer
+    :initarg :time
+    :reader apple-note-time)
+   (mime-subtype
+    :type apple-note-mime-subtype
+    :initarg :mime-subtype
+    :reader apple-note-mime-subtype))
+  (:documentation
+   "Representation of a Note created using Apple's Notes via the IMAP backend"))
+
+(defun apple-note-p (msg)
+  "Checks X-Uniform-Type-Identifier of a MIME:MIME-MESSAGE
+  to determine if a given mime message claims to be an Apple Note."
+  (when-let (uniform-id (car (mime:mime-message-header-values
+                              "X-Uniform-Type-Identifier"
+                              msg)))
+    (string-equal uniform-id "com.apple.mail-note")))
+
+(defun make-apple-note (msg)
+  (check-type msg mime-message)
+
+  (unless (apple-note-p msg)
+    (error "Passed message is not an Apple Note according to headers"))
+
+  (let ((text-part (mime:find-mime-text-part msg))
+        (subject (car (mime:mime-message-header-values "Subject" msg :decode t)))
+        (uuid (when-let ((val (car (mime:mime-message-header-values
+                                    "X-Universally-Unique-Identifier"
+                                    msg))))
+                (string-downcase val)))
+        (time (find-mime-message-date msg)))
+    ;; The idea here is that we don't need to check a lot manually, instead
+    ;; the type annotation are going to do this for us (with sufficient safety?)
+    (change-class msg 'apple-note
+                  :text-part text-part
+                  :subject subject
+                  :uuid uuid
+                  :time time
+                  :mime-subtype (mime:mime-subtype text-part))))
+
+(defgeneric apple-note-html-fragment (note out)
+  (:documentation
+   "Takes an APPLE-NOTE and writes its text content as HTML to
+   the OUT stream. The <object> tags are resolved to <img> which
+   refer to the respective attachment's filename as a relative path,
+   but extraction of the attachments must be done separately. The
+   surrounding <html> and <body> tags are stripped and <head>
+   discarded completely, so only a fragment which can be included
+   in custom templates remains."))
+
+(defmethod apple-note-html-fragment ((note apple-note) (out stream))
+  (let ((text (apple-note-text-part note)))
+    (cond
+      ;; notemap creates text/plain notes we need to handle properly.
+      ;; Additionally we *could* check X-Mailer which notemap sets
+      ((string-equal (apple-note-mime-subtype note) "plain")
+       (html-escape-stream (mime:mime-body-stream text :binary nil) out))
+      ;; Notes.app creates text/html parts
+      ((string-equal (apple-note-mime-subtype note) "html")
+       (closure-html:parse
+        (mime:mime-body-stream text)
+        (make-instance
+         'apple-note-transformer
+         :cid-lookup
+         (lambda (cid)
+           (when-let* ((part (mime:find-mime-part-by-id note (cid-header-value cid)))
+                       (file (mime:mime-part-file-name part)))
+             file))
+         :next-handler
+         (closure-html:make-character-stream-sink out))))
+      (t (error "Internal error: unexpected MIME subtype")))))
diff --git a/users/sterni/mblog/packages.lisp b/users/sterni/mblog/packages.lisp
new file mode 100644
index 000000000000..e4fcb4672828
--- /dev/null
+++ b/users/sterni/mblog/packages.lisp
@@ -0,0 +1,49 @@
+(defpackage :maildir
+  (:use :common-lisp)
+  (:shadow :list)
+  (:export :list)
+  (:documentation
+   "Very incomplete package for dealing with maildir(5)."))
+
+(defpackage :note
+  (:use
+   :common-lisp
+   :closure-html
+   :cl-date-time-parser
+   :mime4cl)
+  (:import-from
+   :alexandria
+   :when-let*
+   :when-let
+   :starts-with-subseq
+   :ends-with-subseq)
+  (:import-from :who :escape-string-minimal)
+  (:export
+   :apple-note
+   :apple-note-uuid
+   :apple-note-subject
+   :apple-note-time
+   :apple-note-text-part
+   :make-apple-note
+   :apple-note-html-fragment))
+
+(defpackage :mblog
+  (:use
+   :common-lisp
+   :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))
diff --git a/users/sterni/mblog/transformer.lisp b/users/sterni/mblog/transformer.lisp
new file mode 100644
index 000000000000..31fcda028ade
--- /dev/null
+++ b/users/sterni/mblog/transformer.lisp
@@ -0,0 +1,127 @@
+(in-package :note)
+(declaim (optimize (safety 3)))
+
+;; Throw away these tags and all of their children
+(defparameter +discard-tags-with-children+ '("HEAD"))
+;; Only “strip” these tags and leave their content as is
+(defparameter +discard-tags-only+ '("BODY" "HTML"))
+
+;; This is basically the same as cxml's PROXY-HANDLER.
+;; Couldn't be bothered to make a BROADCAST-HANDLER because I
+;; only need to pass through to one handler. It accepts every
+;; event and passes it on to NEXT-HANDLER. This is useful for
+;; subclassing mostly where an event can be modified or passed
+;; on as is via CALL-NEXT-METHOD.
+(defclass hax-proxy-handler (hax:default-handler)
+  ((next-handler
+    :initarg :next-handler
+    :accessor proxy-next-handler)))
+
+;; Define the trivial handlers which just call themselves for NEXT-HANDLER
+(macrolet ((def-proxy-handler (name (&rest args))
+             `(defmethod ,name ((h hax-proxy-handler) ,@args)
+                (,name (proxy-next-handler h) ,@args))))
+  (def-proxy-handler hax:start-document (name p-id s-id))
+  (def-proxy-handler hax:end-document ())
+  (def-proxy-handler hax:start-element (name attrs))
+  (def-proxy-handler hax:end-element (name))
+  (def-proxy-handler hax:characters (data))
+  (def-proxy-handler hax:unescaped (data))
+  (def-proxy-handler hax:comment (data)))
+
+(defclass apple-note-transformer (hax-proxy-handler)
+  ((cid-lookup
+    :initarg :cid-lookup
+    :initform (lambda (cid) nil)
+    :accessor transformer-cid-lookup)
+   (discard-until
+    :initarg :discard-until
+    :initform nil
+    :accessor transformer-discard-until)
+   (depth
+    :initarg :depth
+    :initform 0
+    :accessor transformer-depth))
+  (:documentation
+   "HAX handler that strips unnecessary tags from the HTML of a com.apple.mail-note
+   and resolves references to attachments to IMG tags."))
+
+;; Define the “boring” handlers which just call the next method (i. e. the next
+;; handler) unless discard-until is not nil in which case the event is dropped.
+(macrolet ((def-filter-handler (name (&rest args))
+             `(defmethod ,name ((h apple-note-transformer) ,@args)
+                (when (not (transformer-discard-until h))
+                  (call-next-method)))))
+  (def-filter-handler hax:start-document (name p-id s-id))
+  (def-filter-handler hax:end-document ())
+  (def-filter-handler hax:characters (data))
+  (def-filter-handler hax:unescaped (data))
+  (def-filter-handler hax:comment (data)))
+
+(defun parse-content-id (attrlist)
+  (when-let (data (find-if (lambda (x)
+                             (string-equal (hax:attribute-name x) "DATA"))
+                           attrlist))
+    (multiple-value-bind (starts-with-cid-p suffix)
+        (starts-with-subseq "cid:" (hax:attribute-value data)
+                            :return-suffix t :test #'char=)
+      (if starts-with-cid-p suffix data))))
+
+(defmethod hax:start-element ((handler apple-note-transformer) name attrs)
+  (with-accessors ((discard-until transformer-discard-until)
+                   (next-handler proxy-next-handler)
+                   (cid-lookup transformer-cid-lookup)
+                   (depth transformer-depth))
+      handler
+
+    (cond
+      ;; If we are discarding, any started element is dropped,
+      ;; since the end-condition only is reached via END-ELEMENT.
+      (discard-until nil)
+      ;; If we are not discarding any outer elements, we can set
+      ;; up a new discard condition if we encounter an appropriate
+      ;; element.
+      ((member name +discard-tags-with-children+ :test #'string-equal)
+       (setf discard-until (cons name depth)))
+      ;; Only drop this event, must be mirrored in END-ELEMENT to
+      ;; avoid invalidly nested HTML.
+      ((member name +discard-tags-only+ :test #'string-equal) nil)
+      ;; If we encounter an object tag, we drop it and its contents,
+      ;; but only after inspecting its attributes and emitting new
+      ;; events representing an img tag which includes the respective
+      ;; attachment via its filename.
+      ((string-equal name "OBJECT")
+       (progn
+         (setf discard-until (cons "OBJECT" depth))
+         ;; TODO(sterni): check type and only resolve images, raise error
+         ;; otherwise. We should only encounter images anyways, since
+         ;; other types are only supported for iCloud which doesn't seem
+         ;; to use IMAP for sync these days.
+         (when-let* ((cid (parse-content-id attrs))
+                     (file (apply cid-lookup (list cid)))
+                     (src (hax:make-attribute "SRC" file)))
+           (hax:start-element next-handler "IMG" (list src))
+           (hax:end-element next-handler "IMG"))))
+      ;; In all other cases, we use HAX-PROXY-HANDLER to pass the event on.
+      (t (call-next-method)))
+    (setf depth (1+ depth))))
+
+(defmethod hax:end-element ((handler apple-note-transformer) name)
+  (with-accessors ((discard-until transformer-discard-until)
+                   (depth transformer-depth))
+      handler
+
+    (setf depth (1- depth))
+    (cond
+      ;; If we are discarding and encounter the same tag again at the same
+      ;; depth, we can stop, but still have to discard the current tag.
+      ((and discard-until
+            (string-equal (car discard-until) name)
+            (= (cdr discard-until) depth))
+       (setf discard-until nil))
+      ;; In all other cases, we drop properly.
+      (discard-until nil)
+      ;; Mirrored tag stripping as in START-ELEMENT
+      ((member name +discard-tags-only+ :test #'string-equal) nil)
+      ;; In all other cases, we use HAX-PROXY-HANDLER to pass the event on.
+      (t (call-next-method)))))