diff options
Diffstat (limited to 'users/sterni/mblog')
| -rw-r--r-- | users/sterni/mblog/.gitignore | 5 | ||||
| -rw-r--r-- | users/sterni/mblog/cli.lisp | 71 | ||||
| -rw-r--r-- | users/sterni/mblog/default.nix | 44 | ||||
| -rw-r--r-- | users/sterni/mblog/maildir.lisp | 17 | ||||
| -rw-r--r-- | users/sterni/mblog/mblog.lisp | 140 | ||||
| -rw-r--r-- | users/sterni/mblog/note.lisp | 118 | ||||
| -rw-r--r-- | users/sterni/mblog/packages.lisp | 49 | ||||
| -rw-r--r-- | users/sterni/mblog/transformer.lisp | 127 |
8 files changed, 571 insertions, 0 deletions
diff --git a/users/sterni/mblog/.gitignore b/users/sterni/mblog/.gitignore new file mode 100644 index 0000000000..ae957fcad0 --- /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 0000000000..9bc0681df0 --- /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 0000000000..607d198930 --- /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 0000000000..aca014203e --- /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 0000000000..1f971bc121 --- /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 0000000000..45be0f4e88 --- /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 0000000000..e4fcb46728 --- /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 0000000000..31fcda028a --- /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))))) |