diff --git a/elisp/org-mu4e-compose.el b/elisp/org-mu4e-compose.el index 29d9421..b38c149 100644 --- a/elisp/org-mu4e-compose.el +++ b/elisp/org-mu4e-compose.el @@ -9,17 +9,42 @@ (require 'mu4e) (require 'org-mime) (require 'shr) -(require 'dom) (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, @@ -63,11 +88,13 @@ about this change." (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)) - (indent-region (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)))) @@ -88,74 +115,211 @@ This moves point, wrap it in `save-excursion' if that is a problem." (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) - (let ((msg-buffer (current-buffer)) - (buffer (get-buffer-create "*Org-Mu4e HTML Preview*")) - (bounds (point-min)) - (cur-max (point-max))) - (without-restriction - (with-current-buffer buffer - (special-mode) - (setq-local org-mu4e--override-org-mode-check t) - ;; 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) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert-buffer-substring msg-buffer) - (narrow-to-region bounds cur-max) - (org-mu4e--htmlize-and-cleanup)) - (goto-char (point-min)))) - (switch-to-buffer-other-window buffer) - buffer)) + (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 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) - (let ((buffer (get-buffer-create "*Org-Mu4e Render Preview*"))) - (save-excursion - (without-restriction - (goto-char (point-min)) - (if (re-search-forward (rx bol (literal mail-header-separator) eol) - nil t) - (let* ((start (1+ (match-end 0))) - (org-export-with-latex org-mime-org-html-with-latex-default) - (org-preview-latex-image-directory - (expand-file-name "ltximg/" mm-tmp-directory)) - (default-directory org-preview-latex-image-directory) - (org-html-postamble nil)) - (narrow-to-region start (point-max)) - (if-let* ((export-data (org-export-as - 'html nil t nil - org-mime-export-options))) - (progn - (with-current-buffer buffer - (special-mode) - (let ((inhibit-read-only t) - (default-directory - org-preview-latex-image-directory)) - (erase-buffer) - (insert export-data) - (shr-render-region (point-min) (point-max)) - ;; The above function inserts a text directionality - ;; character and then two newlines, just to be safe, - ;; check for them, then hide them - (goto-char (point-min)) - (let ((new-start (point-min))) - (when (or (eq (char-after) #x200e) - (eq (char-after) #x200f)) - (cl-incf new-start)) - (dotimes (_ 2) - (forward-char) - (when (eq (char-after) ?\n) - (cl-incf new-start))) - (narrow-to-region new-start (point-max))))) - (switch-to-buffer-other-window buffer)) - (user-error "HTML export failed"))) - (user-error "Can't find message start in current buffer")))))) + (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.