mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refactor(sterni/mblog): add (sub)class for apple note messages

Browse source 
* Upon creation of an apple-note object we can check if certain fields
  we are interested in are present and of the right type etc.

  These currently are:

  - UUID (for links later)
  - Subject (title)
  - Time
  - Text part with supported MIME type

  These are then put into their own shortcut fields in the apple-note
  subclass which allows for easier access and forces us to make sure
  they are present.

* Split out everything note related into its own package. Using the new
  type, we can expose an interface which sort of makes sense.

Change-Id: Ic9d67518354e61a3cc8388bb0e566fce661e90d0
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5072
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
This commit is contained in:
sterni 2022-01-13 00:33:59 +01:00
parent d0e30ed23a
commit 56ec3b1803
5 changed files with 105 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
users/sterni/mblog/cli.lisp
View file

@ -13,5 +13,6 @@
args)))) args))))
(if help-p (format *error-output* "Usage: ~A~%" +synopsis+) (if help-p (format *error-output* "Usage: ~A~%" +synopsis+)
(loop for arg in args (loop for arg in args
do (apple-note-html-fragment do (note:apple-note-html-fragment
(mime:mime-message (pathname arg)) *standard-output*))))) (note:make-apple-note (mime:mime-message (pathname arg)))
*standard-output*)))))

1
users/sterni/mblog/default.nix
View file

@ -18,6 +18,7 @@ depot.nix.buildLisp.program {
} }
depot.third_party.lisp.alexandria depot.third_party.lisp.alexandria
depot.third_party.lisp.closure-html depot.third_party.lisp.closure-html
depot.third_party.lisp.cl-date-time-parser
depot.third_party.lisp.cl-who depot.third_party.lisp.cl-who
depot.third_party.lisp.mime4cl depot.third_party.lisp.mime4cl
]; ];

101
users/sterni/mblog/note.lisp
View file

@ -1,4 +1,4 @@
(in-package :mblog) (in-package :note)
(declaim (optimize (safety 3))) (declaim (optimize (safety 3)))
;;; util ;;; util
@ -15,46 +15,107 @@
surrounds them with angle brackets for a MIME header" surrounds them with angle brackets for a MIME header"
(concatenate 'string "<" cid ">")) (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 ;;; 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) (defun apple-note-p (msg)
"Checks X-Uniform-Type-Identifier of a MIME:MIME-MESSAGE "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" (when-let (uniform-id (assoc "X-Uniform-Type-Identifier"
(mime:mime-message-headers msg) (mime:mime-message-headers msg)
:test #'string-equal)) :test #'string-equal))
(string-equal (cdr uniform-id) "com.apple.mail-note"))) (string-equal (cdr uniform-id) "com.apple.mail-note")))
(defun apple-note-html-fragment (msg out) (defun make-apple-note (msg)
"Takes a MIME:MIME-MESSAGE and writes its text content as HTML to (check-type msg mime-message)
the OUT stream. The <object> tags are resolved to <img> which
refer to the respective attachment's filename as a relative path, (unless (apple-note-p msg)
but extraction of the attachments must be done separately. The (error "Passed message is not an Apple Note according to headers"))
surrounding <html> and <body> tags are stripped and <head>
discarded completely, so only a fragment which can be included (let ((text-part (mime:find-mime-text-part msg))
in custom templates remains." (subject (find-mime-message-header "Subject" msg))
(let ((text (find-mime-text-part 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 (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. ;; notemap creates text/plain notes we need to handle properly.
;; Additionally we *could* check X-Mailer which notemap sets ;; 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)) (html-escape-stream (mime:mime-body-stream text :binary nil) out))
;; Notes.app creates text/html parts ;; Notes.app creates text/html parts
((string-equal (mime:mime-subtype text) "html") ((string-equal (apple-note-mime-subtype note) "html")
(closure-html:parse (closure-html:parse
(mime:mime-body-stream text) (mime:mime-body-stream text)
(make-instance (make-instance
'apple-note-transformer 'apple-note-transformer
:cid-lookup :cid-lookup
(lambda (cid) (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 (mime:mime-part-file-name part)))
file)) file))
:next-handler :next-handler
(closure-html:make-character-stream-sink out)))) (closure-html:make-character-stream-sink out))))
(t (error "Malformed Apple Note: unknown mime type"))))) (t (error "Internal error: unexpected MIME subtype")))))

23
users/sterni/mblog/packages.lisp
View file

@ -5,18 +5,33 @@
(:documentation (:documentation
"Very incomplete package for dealing with maildir(5).")) "Very incomplete package for dealing with maildir(5)."))
(defpackage :mblog (defpackage :note
(:use (:use
:common-lisp :common-lisp
:mime4cl
:closure-html :closure-html
:who :who
:uiop) :cl-date-time-parser
(:shadow :with-html-output) ; conflict between closure-html and who :mime4cl
:who)
(:import-from (:import-from
:alexandria :alexandria
:when-let* :when-let*
:when-let :when-let
:starts-with-subseq :starts-with-subseq
:ends-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)) (:export :main))

2
users/sterni/mblog/transformer.lisp
View file

@ -1,4 +1,4 @@
(in-package :mblog) (in-package :note)
(declaim (optimize (safety 3))) (declaim (optimize (safety 3)))
;; Throw away these tags and all of their children ;; Throw away these tags and all of their children