diff options
| -rw-r--r-- | users/sterni/mblog/cli.lisp | 5 | ||||
| -rw-r--r-- | users/sterni/mblog/default.nix | 1 | ||||
| -rw-r--r-- | users/sterni/mblog/note.lisp | 101 | ||||
| -rw-r--r-- | users/sterni/mblog/packages.lisp | 23 | ||||
| -rw-r--r-- | users/sterni/mblog/transformer.lisp | 2 |
5 files changed, 105 insertions, 27 deletions
diff --git a/users/sterni/mblog/cli.lisp b/users/sterni/mblog/cli.lisp index 93be7e8b8e44..14c7adda28ed 100644 --- a/users/sterni/mblog/cli.lisp +++ b/users/sterni/mblog/cli.lisp @@ -13,5 +13,6 @@ args)))) (if help-p (format *error-output* "Usage: ~A~%" +synopsis+) (loop for arg in args - do (apple-note-html-fragment - (mime:mime-message (pathname arg)) *standard-output*))))) + do (note:apple-note-html-fragment + (note:make-apple-note (mime:mime-message (pathname arg))) + *standard-output*))))) diff --git a/users/sterni/mblog/default.nix b/users/sterni/mblog/default.nix index 1c2776ec9250..f8ba70b90bd1 100644 --- a/users/sterni/mblog/default.nix +++ b/users/sterni/mblog/default.nix @@ -18,6 +18,7 @@ depot.nix.buildLisp.program { } 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.mime4cl ]; diff --git a/users/sterni/mblog/note.lisp b/users/sterni/mblog/note.lisp index 660b4826b1ad..0091e97b083f 100644 --- a/users/sterni/mblog/note.lisp +++ b/users/sterni/mblog/note.lisp @@ -1,4 +1,4 @@ -(in-package :mblog) +(in-package :note) (declaim (optimize (safety 3))) ;;; util @@ -15,46 +15,107 @@ surrounds them with angle brackets for a MIME header" (concatenate 'string "<" cid ">")) +;; TODO(sterni): move into mime4cl +(defun find-mime-message-header (header-name message) + (when-let ((header (assoc header-name + (mime:mime-message-headers message) + :test #'string-equal))) + (cdr header))) + +(defun find-mime-message-date (message) + (when-let ((date-string (find-mime-message-header "Date" message))) + (date-time-parser:parse-date-time date-string))) + ;;; main implementation -;; TODO(sterni): make this a “parser” instead of a predicate +(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 using 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 is an Apple Note." + to determine if a given mime message claims to be an Apple Note." (when-let (uniform-id (assoc "X-Uniform-Type-Identifier" (mime:mime-message-headers msg) :test #'string-equal)) (string-equal (cdr uniform-id) "com.apple.mail-note"))) -(defun apple-note-html-fragment (msg out) - "Takes a MIME:MIME-MESSAGE 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." - (let ((text (find-mime-text-part msg))) +(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 (find-mime-message-header "Subject" msg)) + (uuid (when-let ((val (find-mime-message-header + "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 - ;; Sanity checking of the note - ((not (apple-note-p msg)) - (error "Unsupported or missing X-Uniform-Type-Identifier")) - ((not text) (error "Malformed Apple Note: no text part")) ;; notemap creates text/plain notes we need to handle properly. ;; Additionally we *could* check X-Mailer which notemap sets - ((string-equal (mime:mime-subtype text) "plain") + ((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 (mime:mime-subtype text) "html") + ((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 msg (cid-header-value 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 "Malformed Apple Note: unknown mime type"))))) + (t (error "Internal error: unexpected MIME subtype"))))) diff --git a/users/sterni/mblog/packages.lisp b/users/sterni/mblog/packages.lisp index a58aad27d11b..1d5aa07313ca 100644 --- a/users/sterni/mblog/packages.lisp +++ b/users/sterni/mblog/packages.lisp @@ -5,18 +5,33 @@ (:documentation "Very incomplete package for dealing with maildir(5).")) -(defpackage :mblog +(defpackage :note (:use :common-lisp - :mime4cl :closure-html :who - :uiop) - (:shadow :with-html-output) ; conflict between closure-html and who + :cl-date-time-parser + :mime4cl + :who) (:import-from :alexandria :when-let* :when-let :starts-with-subseq :ends-with-subseq) + (:shadow :with-html-output) ; conflict between closure-html and who + (: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 + :uiop + :note) (:export :main)) diff --git a/users/sterni/mblog/transformer.lisp b/users/sterni/mblog/transformer.lisp index 67f1ff0e1d79..31fcda028ade 100644 --- a/users/sterni/mblog/transformer.lisp +++ b/users/sterni/mblog/transformer.lisp @@ -1,4 +1,4 @@ -(in-package :mblog) +(in-package :note) (declaim (optimize (safety 3))) ;; Throw away these tags and all of their children |