chore(users/sterni/mblog): rename apple-note to mail-note
The type identifier Apple uses is com.apple.mail-note, so “Mail Note” is actually the best way to refer to this format. Not only doesn't it include a trademark, but it's also more accurate. The iOS and macOS Notes.app(s) allow authoring Notes to be saved in iCloud which seems to use a different API and/or storage format (at least these notes are no longer accessible via IMAP). In this sense they are “Apple Notes”, but not “Mail Notes”. Change-Id: I2fd3d3bd253ed39adf7965008290f7d1e622831d Reviewed-on: https://cl.tvl.fyi/c/depot/+/12815 Autosubmit: sterni <sternenseemann@systemli.org> Tested-by: BuildkiteCI Reviewed-by: sterni <sternenseemann@systemli.org>
This commit is contained in:
sterni
clbot
parent
b8e4da856f
commit
0ead86ec89
6 changed files with 60 additions and 60 deletions
130
users/sterni/mblog/mail-note/html-transformer.lisp
Normal file
130
users/sterni/mblog/mail-note/html-transformer.lisp
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
;; SPDX-License-Identifier: GPL-3.0-only
|
||||
;; SPDX-FileCopyrightText: Copyright (C) 2022, 2024 by sterni
|
||||
|
||||
(in-package :mail-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 mail-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 mail-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 mail-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 mail-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)))))
|
||||
118
users/sterni/mblog/mail-note/note.lisp
Normal file
118
users/sterni/mblog/mail-note/note.lisp
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
;; SPDX-License-Identifier: GPL-3.0-only
|
||||
;; SPDX-FileCopyrightText: Copyright (C) 2022-2024 by sterni
|
||||
|
||||
(in-package :mail-note)
|
||||
(declaim (optimize (safety 3)))
|
||||
|
||||
;;; util
|
||||
|
||||
(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 config:*general-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 Mail 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 mail-note-mime-subtype-p (x)
|
||||
(member x '("plain" "html") :test #'string-equal))
|
||||
|
||||
(deftype mail-note-mime-subtype ()
|
||||
'(satisfies mail-note-mime-subtype-p))
|
||||
|
||||
(defclass mail-note (mime:mime-message)
|
||||
((text-part
|
||||
:type mime:mime-text
|
||||
:initarg :text-part
|
||||
:reader mail-note-text-part)
|
||||
(subject
|
||||
:type string
|
||||
:initarg :subject
|
||||
:reader mail-note-subject)
|
||||
(uuid
|
||||
:type string
|
||||
:initarg :uuid
|
||||
:reader mail-note-uuid)
|
||||
(time
|
||||
:type integer
|
||||
:initarg :time
|
||||
:reader mail-note-time)
|
||||
(mime-subtype
|
||||
:type mail-note-mime-subtype
|
||||
:initarg :mime-subtype
|
||||
:reader mail-note-mime-subtype))
|
||||
(:documentation
|
||||
"Representation of a Mail Note, e.g. created using Apple's Notes App via the IMAP backend"))
|
||||
|
||||
(defun mail-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) Mail 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-mail-note (msg)
|
||||
(check-type msg mime-message)
|
||||
|
||||
(unless (mail-note-p msg)
|
||||
(error "Passed message is not a Mail 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 'mail-note
|
||||
:text-part text-part
|
||||
:subject subject
|
||||
:uuid uuid
|
||||
:time time
|
||||
:mime-subtype (mime:mime-subtype text-part))))
|
||||
|
||||
(defgeneric mail-note-html-fragment (note out)
|
||||
(:documentation
|
||||
"Takes an MAIL-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 mail-note-html-fragment ((note mail-note) (out stream))
|
||||
(let ((text (mail-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 (mail-note-mime-subtype note) "plain")
|
||||
(html-escape-stream (mime:mime-body-stream text) out))
|
||||
;; Notes.app creates text/html parts
|
||||
((string-equal (mail-note-mime-subtype note) "html")
|
||||
(closure-html:parse
|
||||
(mime:mime-body-stream text)
|
||||
(make-instance
|
||||
'mail-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")))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue