Files
emacs-config/elisp/org-mu4e-compose.el

526 lines
21 KiB
EmacsLisp

;;; org-mu4e-compose.el --- Write mu4e messages with org-mode. -*- lexical-binding: t; -*-
;;; Commentary:
;; I use evil. This file does not depend on evil, but some of these keybindings
;; shadow useful org keybinding with message mode keybindings because the org
;; bindings being shadowed are available with evil under some other key sequence.
;;; Code:
(require 'mu4e)
(require 'org-mime)
(require 'shr)
(require 'sgml-mode)
(require 'cl-lib)
(require 'rx)
(defcustom org-mu4e-preview-html-images t
"If non-nil, render images in rendered HTML preview buffers.
This can be toggled locally with `org-mu4e-toggle-preview-images'."
:type 'boolean)
(defvar-local org-mu4e--html-message-p t
"Weather or not the current message should be htmlized.")
(defvar-local org-mu4e--override-org-mode-check nil
"Internal variable.
See `org-mu4e--override-org-mode-check-advice' for information about what this
does.")
(defvar org-mu4e--internal-message-mode-function
(symbol-function 'mu4e-compose-mode)
"The `message-mode' (or derived mode) used by `org-mu4e-compose-mode'.")
(defvar-local org-mu4e--preview-message-buffer nil
"The message buffer that backs this preview buffer.")
(defun org-mu4e--override-org-mode-check-advice (oldfun &rest r)
"Around advice for various org mode functions.
This function will call OLDFUN with arguments R with `major-mode' let-bound to
\\='org-mode when `org-mu4e--override-org-mode-check' is t."
(let ((major-mode (if org-mu4e--override-org-mode-check
'org-mode
major-mode)))
(apply oldfun r)))
(advice-add 'org-element-at-point :around
'org-mu4e--override-org-mode-check-advice)
(defun org-mu4e-toggle-htmlize-mssage (&optional arg no-message)
"Toggle weather the current message should be htmlized.
If ARG is a positive number or zero, enable htmlization, if it is negative,
disable it. Otherwise, toggle it. With NO-MESSAGE, don't display a message
about this change."
(interactive "P")
(setq org-mu4e--html-message-p (or (wholenump arg)
(and (not arg)
(not org-mu4e--html-message-p))))
(unless no-message
(message "Message will be %ssent with an HTML part."
(if org-mu4e--html-message-p "" "not ")))
(force-mode-line-update))
(defun org-mu4e--bounds-of-mime-part (type)
"Find the bounds of the mime part for TYPE in the current buffer."
(save-excursion
(goto-char (point-min))
(when (and
(re-search-forward (rx bol (literal mail-header-separator) eol)
nil t)
(re-search-forward (rx "<#multipart" (* any) ">")
nil t)
(re-search-forward (rx "<#part " (* any)
"type=" (literal type) (* any) ">")
nil t))
(let ((start (match-end 0))
(end (point-max)))
(when (re-search-forward
(rx (or (and "<#/" (or "part" "multipart") ">")
(and "<#part" (* any) ">")))
nil t)
(setq end (match-beginning 0)))
(cons (1+ start) end)))))
(defun org-mu4e--pretty-print-fontify-html-part ()
"Pretty print and fontify the HTML part of the current buffer."
(when-let* ((bounds (org-mu4e--bounds-of-mime-part "text/html"))
(real-buf (current-buffer)))
(save-excursion
(let ((content
(with-temp-buffer
(insert-buffer-substring real-buf (car bounds) (cdr bounds))
(make-local-variable 'delay-mode-hooks) ;; prevent warnings
(let ((delay-mode-hooks t)
delayed-mode-hooks)
(html-mode))
(sgml-pretty-print (point-min) (point-max))
(let ((inhibit-message t))
(indent-region (point-min) (point-max)))
(put-text-property (point-min) (point-max) 'fontified nil)
(font-lock-ensure)
(buffer-string))))
(delete-region (car bounds) (cdr bounds))
(goto-char (car bounds))
(insert content)))))
(defun org-mu4e--htmlize-and-cleanup ()
"HTMLize and cleanup the visible portion of the buffer.
This moves point, wrap it in `save-excursion' if that is a problem."
(org-mime-htmlize)
;; IDK why, but the above function adds a bunch of newlines to the end
;; of the buffer.
(goto-char (point-min))
(when (re-search-forward (rx (group (* "\n")) "\n" eos) nil t)
(delete-region (match-beginning 1)
(match-end 1)))
(font-lock-ensure)
(org-mu4e--pretty-print-fontify-html-part))
(defvar-keymap org-mu4e--code-preview-mode-map
:doc "Keymap for `org-mu4e--code-preview-mode'."
"r" #'revert-buffer-quick)
(with-eval-after-load 'evil
(evil-define-key* 'normal org-mu4e--code-preview-mode-map
"r" #'revert-buffer-quick))
(define-derived-mode org-mu4e--code-preview-mode special-mode
"Org-Mu4e-Code-Preview"
"Major mode used in the buffere created by `org-mu4e-preview-html'."
(setq-local org-mu4e--override-org-mode-check t
revert-buffer-function #'org-mu4e--html-code-revert-function)
(font-lock-mode -1)
;; Setup font-lock without all the other pesky major mode stuff
(org-set-font-lock-defaults)
(font-lock-add-keywords nil message-font-lock-keywords))
(cl-defun org-mu4e--get-preview-buffer (name mode)
"Get the preview buffer for the current message buffer, possibly creating it.
NAME is a template name to pass to `generate-new-buffer'. MODE is the major
mode of the buffer. Only buffers of this MODE will be returned."
(let ((msg-buf (current-buffer)))
;; first try to find an existing byffer
(dolist (buffer (buffer-list))
(when (and (eq (buffer-local-value
'org-mu4e--preview-message-buffer buffer)
msg-buf)
(eq (buffer-local-value 'major-mode buffer) mode))
(cl-return-from org-mu4e--get-preview-buffer buffer)))
;; create a new buffer
(with-current-buffer (generate-new-buffer name)
(funcall mode)
(setq-local org-mu4e--preview-message-buffer msg-buf)
(current-buffer))))
(defun org-mu4e--render-html-code-preview ()
"Render the HTML preview for the current preview buffer.
This must be called from an HTML preview buffer (as created by
`org-mu4e--get-preview-buffer'."
(let ((start (point))
(inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring org-mu4e--preview-message-buffer)
(org-mu4e--htmlize-and-cleanup)
(goto-char start)))
(defun org-mu4e--html-code-revert-function (&rest _r)
"Revert an `org-mu4e--code-preview-mode' buffer."
(org-mu4e--render-html-code-preview)
(message "Re-rendering..."))
(cl-defmacro org-mu4e--with-preview-buffer ((name mode) &rest body)
"Execute BODY within a preview buffer and return that buffer.
The preview buffer is created with `org-mu4e--get-code-preview-buffer' with NAME
and MODE."
(declare (indent 1))
(let ((buffer (make-symbol "buffer")))
`(let ((,buffer (org-mu4e--get-preview-buffer ,name ,mode)))
(with-current-buffer ,buffer
,@body
(unless (get-buffer-window ,buffer (selected-frame))
(switch-to-buffer-other-window ,buffer))
,buffer))))
(defun org-mu4e-preview-html ()
"Preview the HTML version of the current buffer in a new buffer.
Return the newly created buffer."
(interactive)
(org-mu4e--with-preview-buffer
("*Org-Mu4e HTML Preview*" 'org-mu4e--code-preview-mode)
(org-mu4e--render-html-code-preview)))
(defun org-mu4e-toggle-preview-images ()
"Toggle whether image previews should be shown in the current buffer."
(interactive)
(cl-callf not shr-inhibit-images)
(org-mu4e--render-message-html))
(defvar-keymap org-mu4e--rendered-preview-mode-map
:doc "Keymap for `org-mu4e--rendered-preview-mode'."
"r" #'revert-buffer-quick
"t" #'org-mu4e-toggle-preview-images)
(with-eval-after-load 'evil
(evil-define-key* 'normal org-mu4e--rendered-preview-mode-map
"r" #'revert-buffer-quick
"t" #'org-mu4e-toggle-preview-images))
(define-derived-mode org-mu4e--rendered-preview-mode special-mode
'("Org-Mu4e-Rendered-Preview" (shr-inhibit-images "" "/i"))
(setq-local revert-buffer-function
#'org-mu4e--rendered-preview-revert-function
org-export-with-latex org-mime-org-html-with-latex-default
org-html-preamble nil
shr-inhibit-images (not org-mu4e-preview-html-images)))
(defconst org-mu4e--allowed-part-properties
'("type" "filename" "id" "disposition")
"List of allowed properties for `org-mu4e--read-part-properties'.")
(cl-defun org-mu4e--read-part-properties ()
"Read the <#part> statement at point, moving poing to the end.
This returns a plist of the properties of the statement."
(when (looking-at (regexp-quote "<#part "))
(forward-char (length "<#part "))
(let (out)
(while (looking-at
(rx (* (or " " "\t" "\n"))
(group (+ (any "a-z" "A-Z"))) "=" (? (group "\""))))
(let ((name (match-string 1))
(is-string (match-string 2))
val)
(goto-char (1+ (match-end 1)))
(setq val (if is-string
(prog1
(read (current-buffer))
(forward-char))
(let ((start (point)))
(re-search-forward (rx (or " " "\t" eol ">")))
(buffer-substring-no-properties
start (match-beginning 0)))))
(unless (stringp val)
(cl-return-from org-mu4e--read-part-properties))
(when (member name org-mu4e--allowed-part-properties)
(push val out)
(push (intern (concat ":" name)) out))))
(unless (eql (char-before) ?>)
(cl-return-from org-mu4e--read-part-properties))
(re-search-forward (rx (or "<#/part>" (group "<#part"))))
(when-let* ((end (match-beginning 1)))
(goto-char end))
out)))
(cl-defun org-mu4e--extract-inline-html-file-parts ()
"Search through the buffer and find all parts that point to external images.
This returns a hash table of cid -> path."
(let (is-html-part out)
(while (re-search-forward
(rx "<#multipart" (+ (any blank))
"type=" (or "related" "\"related\"")
(* (any blank)) ">")
nil t)
(setq is-html-part nil
out (make-hash-table :test 'equal))
(let ((start (match-end 0)))
(search-forward "<#/multipart>")
(with-restriction start (match-beginning 0)
(goto-char (point-min))
(while-let ((props (org-mu4e--read-part-properties))
(type (plist-get props :type)))
(cond
((equal type "text/html")
(setq is-html-part t))
((string-prefix-p "image/" type)
(when-let* ((id (plist-get props :id))
(filename (plist-get props :filename)))
;; remove the < > from the id
(puthash (substring id 1 (1- (length id))) filename out)))))))
(when is-html-part
(cl-return-from org-mu4e--extract-inline-html-file-parts out)))))
(defun org-mu4e--replace-cid-images ()
"Replace the src property of all <img> tags that have a protocol of cid."
(let ((bounds (org-mu4e--bounds-of-mime-part "text/html"))
(cid-map (save-excursion
(goto-char (point-min))
(org-mu4e--extract-inline-html-file-parts))))
(save-excursion
(with-restriction (car bounds) (cdr bounds)
(goto-char (point-min))
(while (re-search-forward (rx "src=" (group "\"cid:")) nil t)
(goto-char (match-beginning 1))
(let ((start (point))
(src (read (current-buffer))))
(when-let ((file (gethash (substring src 4) cid-map)))
(delete-region start (point))
(insert (prin1-to-string (concat "file://" file))))))))))
(defun org-mu4e--render-message-html ()
"Render the HTMLized message buffer for the current preview buffer."
(let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring org-mu4e--preview-message-buffer)
(org-mime-htmlize)
(org-mu4e--replace-cid-images)
(let ((bounds (org-mu4e--bounds-of-mime-part "text/html")))
(delete-region (cdr bounds) (point-max))
(delete-region (point-min) (car bounds)))
(shr-render-region (point-min) (point-max))))
(defun org-mu4e--rendered-preview-revert-function (&rest _r)
"Revert function for `org-mu4e--rendered-preview-mode."
(message "Re-rendering...")
(org-mu4e--render-message-html))
(defun org-mu4e-render-preview ()
"Render a preview of the HTML message."
(interactive)
(with-current-buffer
(org-mu4e--with-preview-buffer
("*Org-Mu4e Render Preview*" 'org-mu4e--rendered-preview-mode))
;; make sure the buffer is shown when wo do this so the image's width is
;; correct
(org-mu4e--render-message-html)))
(defun org-mu4e-send (&optional arg)
"HTMLize and send the message in the current buffer.
ARG is passed directly to `message-send'."
;; This has to return a non-nil value so that org knows we handled the C-c C-c
(interactive "P")
(let ((modified (buffer-modified-p))
;; we only restore the restriction if the sending below fails
(old-rest (cons (point-min) (point-max))))
(widen)
(let ((save-text (buffer-substring-no-properties (point-min)
(point-max))))
(condition-case _
(progn
(when org-mu4e--html-message-p
(org-mu4e--htmlize-and-cleanup))
(message-send arg)
'sent)
((or error quit)
(erase-buffer)
(insert save-text)
(narrow-to-region (car old-rest) (cdr old-rest))
(restore-buffer-modified-p modified)
'failed)))))
(defun org-mu4e-send-and-exit (&optional arg)
"Call `org-mu4e-send', the save and kill the buffer.
ARG is passed directly to `message-send'."
(interactive "P")
(when (eq (org-mu4e-send arg) 'sent)
(message-kill-buffer))
t ;; this tells org that we have handled the C-c C-c
)
(defmacro org-mu4e--with-replaced-compse-func (&rest body)
"Evaluate BODY with `mu4e-compose-mode' rebound to `org-mu4e-compose-mode'.
This makes use of `cl-letf' internally."
`(let ((org-mu4e--internal-message-mode-function
(symbol-function 'mu4e-compose-mode)))
(cl-letf (((symbol-function 'mu4e-compose-mode) 'org-mu4e-compose-mode))
,@body)))
;;;###autoload
(defun org-mu4e-compose-new (&rest r)
"This is like `mu4e-compose-new', but it utilizes `org-mu4e-compose-mode'.
Each of the arguments in R are the same as `mu4e-compose-new', and are directly
passed to it."
(interactive)
(org-mu4e--with-replaced-compse-func
(apply 'mu4e-compose-new r)))
;;;###autoload
(defun org-mu4e-compose-reply-to (&optional to wide)
"This is like `mu4e-compose-reply-to', but utilizes `org-mu4e-compose-mode'.
TO and WIDE are the same as `mu4e-compose-reply-to'."
(interactive)
;; Save local variables set by `mu4e-compose-reply-to'
(let ((html-part-p (seq-find (lambda (handle)
(equal (mm-handle-media-type (cdr handle))
"text/html"))
gnus-article-mime-handle-alist)))
(org-mu4e--with-replaced-compse-func
(let ((buf (mu4e-compose-reply-to to wide)))
(with-current-buffer buf
(setq org-mu4e--html-message-p
;; make the variable look nicer by not having random data in it
(not (not html-part-p))))))))
;;;###autoload
(defun org-mu4e-compose-reply (&optional wide)
"This is like `mu4e-compose-reply', but utilizes `org-mu4e-compose-mode'.
WIDE is the same as `mu4e-compose-reply'."
(interactive "P")
(org-mu4e-compose-reply-to nil wide))
;;;###autoload
(defun org-mu4e-compose-edit ()
"This is like `mu4e-compose-edit', but utilizes `org-mu4e-compose-mode'."
(interactive)
(org-mu4e--with-replaced-compse-func
(mu4e-compose-edit)))
;;;###autoload
(defvar-keymap org-mu4e-compose-mode-map
:parent org-mode-map
;; These come straight from `message-mode-map' and override `org-mode-map'
"C-c C-f C-t" #'message-goto-to
"C-c C-f C-o" #'message-goto-from
"C-c C-f C-b" #'message-goto-bcc
"C-c C-f C-w" #'message-goto-fcc
"C-c C-f C-c" #'message-goto-cc
"C-c C-f C-s" #'message-goto-subject
"C-c C-f C-r" #'message-goto-reply-to
"C-c C-f C-d" #'message-goto-distribution
"C-c C-f C-f" #'message-goto-followup-to
"C-c C-f C-m" #'message-goto-mail-followup-to
"C-c C-f C-k" #'message-goto-keywords
"C-c C-f C-u" #'message-goto-summary
"C-c C-f C-i" #'message-insert-or-toggle-importance
"C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to
;; modify headers (and insert notes in body)
"C-c C-f s" #'message-change-subject
;;
"C-c C-f x" #'message-cross-post-followup-to
;; prefix+message-cross-post-followup-to = same without cross-post
"C-c C-f t" #'message-reduce-to-to-cc
"C-c C-f a" #'message-add-archive-header
;; mark inserted text
"C-c M-m" #'message-mark-inserted-region
"C-c M-f" #'message-mark-insert-file
"C-c C-b" #'message-goto-body
"C-c C-i" #'message-goto-signature
"C-c C-t" #'message-insert-to
"C-c C-f w" #'message-insert-wide-reply
"C-c C-f C-e" #'message-insert-expires
"C-c M-u" #'message-insert-or-toggle-importance
"C-c M-n" #'message-insert-disposition-notification-to
"C-c C-y" #'message-yank-original
"C-c C-M-y" #'message-yank-buffer
"C-c C-S-q" #'message-fill-yanked-message
"C-c M-s" #'message-insert-signature
"C-c M-h" #'message-insert-headers
"C-c M-o" #'message-sort-headers
;; C-c C-c to send and exit is handled by `org-ctrl-c-ctrl-c-hook'
"C-c C-s" #'org-mu4e-send
"C-c C-k" #'message-kill-buffer
"C-c C-d" #'message-dont-send
"C-c M-k" #'message-kill-address
"C-c M-e" #'message-elide-region
"C-c M-v" #'message-delete-not-region
"C-c M-z" #'message-kill-to-signature
"<remap> <split-line>" #'message-split-line
"<remap> <beginning-of-buffer>" #'mu4e-compose-goto-top
"<remap> <end-of-buffer>" #'mu4e-compose-goto-bottom
"C-c M-r" #'message-insert-screenshot
"M-n" #'message-display-abbrev
"C-c C-a" #'mail-add-attachment
"C-c M-t" #'org-mu4e-toggle-htmlize-mssage
"C-c M-p C-p" #'org-mu4e-preview-html
"C-c M-p C-w" #'org-mu4e-render-preview
"C-c C-;" #'mu4e-compose-context-switch)
;;;###autoload
(define-derived-mode org-mu4e-compose-mode org-mode "mu4e:org-compose"
"Major mode for editing mu4e messages with `org-mode' syntax.
This is derived from `org-mode', but it also essentially runs
`mu4e-compose-mode' and `message-mode'. Therefore, it runs their hooks too."
;; Enable all the things from `mu4e-compose-mode' (which derives from
;; `message-mode'), but don't let it change the major mode (or other things we
;; care about).
(when org-mu4e--internal-message-mode-function
(let ((major-mode major-mode)
(mode-name mode-name)
(local-abbrev-table local-abbrev-table)
(font-lock-defaults font-lock-defaults)
;; some of these are not actually changed, but they are here just in
;; case they change in the future...
(comment-start comment-start)
(comment-end comment-end)
(comment-start-skip comment-start-skip)
(comment-add comment-add)
(comment-style comment-style))
(cl-letf (((symbol-function 'kill-all-local-variables) 'ignore)
((symbol-function 'use-local-map) 'ignore)
((symbol-function 'set-syntax-table) 'ignore))
(funcall org-mu4e--internal-message-mode-function))))
;; Add `message-mode' keyword and quote highlighting on top of the org syntax
;; highlighting
(font-lock-add-keywords nil message-font-lock-keywords)
(setq-local org-mu4e--override-org-mode-check t
org-export-with-toc nil)
(add-to-list (make-local-variable 'org-ctrl-c-ctrl-c-final-hook)
'org-mu4e-send-and-exit)
(add-to-list (make-local-variable 'mode-line-misc-info)
'(:eval (if org-mu4e--html-message-p
"Text/HTML "
"Text Only "))))
;;;###autoload(derived-mode-add-parents 'org-mu4e-compose-mode '(mu4e-compose-mode))
(derived-mode-add-parents 'org-mu4e-compose-mode '(mu4e-compose-mode))
;;;###autoload
(define-mail-user-agent 'org-mu4e-user-agent
#'org-mu4e-compose-new
#'org-mu4e-send-and-exit
#'message-kill-buffer
'message-send-hook)
;;;###autoload
(defun org-mu4e-user-agent ()
"Return `org-mu4e-user-agent'."
'org-mu4e-user-agent)
(provide 'org-mu4e-compose)
;;; org-mu4e-compose.el ends here