Fix previews in elisp/org-mu4e-compose.el

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))
+  (org-mu4e--with-preview-buffer
-        (buffer (get-buffer-create "*Org-Mu4e HTML Preview*"))
+      ("*Org-Mu4e HTML Preview*" 'org-mu4e--code-preview-mode)
-        (bounds (point-min))
+    (org-mu4e--render-html-code-preview)))
-        (cur-max (point-max)))
+
-    (without-restriction
+(defun org-mu4e-toggle-preview-images ()
-      (with-current-buffer buffer
+  "Toggle whether image previews should be shown in the current buffer."
-        (special-mode)
+  (interactive)
-        (setq-local org-mu4e--override-org-mode-check t)
+  (cl-callf not shr-inhibit-images)
-        ;; Setup font-lock without all the other pesky major mode stuff
+  (org-mu4e--render-message-html))
-        (org-set-font-lock-defaults)
+
-        (font-lock-add-keywords nil message-font-lock-keywords)
+(defvar-keymap org-mu4e--rendered-preview-mode-map
-        (let ((inhibit-read-only t))
+  :doc "Keymap for `org-mu4e--rendered-preview-mode'."
-          (erase-buffer)
+  "r" #'revert-buffer-quick
-          (insert-buffer-substring msg-buffer)
+  "t" #'org-mu4e-toggle-preview-images)
-          (narrow-to-region bounds cur-max)
+
-          (org-mu4e--htmlize-and-cleanup))
+(with-eval-after-load 'evil
-        (goto-char (point-min))))
+  (evil-define-key* 'normal org-mu4e--rendered-preview-mode-map
-    (switch-to-buffer-other-window buffer)
+    "r" #'revert-buffer-quick
-    buffer))
+    "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)
-  (let ((buffer (get-buffer-create "*Org-Mu4e Render Preview*")))
+  (with-current-buffer
-    (save-excursion
+      (org-mu4e--with-preview-buffer
-      (without-restriction
+          ("*Org-Mu4e Render Preview*" 'org-mu4e--rendered-preview-mode))
-        (goto-char (point-min))
+    ;; make sure the buffer is shown when wo do this so the image's width is
-        (if (re-search-forward (rx bol (literal mail-header-separator) eol)
+    ;; correct
-                               nil t)
+    (org-mu4e--render-message-html)))
-            (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"))))))
 
 (defun org-mu4e-send (&optional arg)
   "HTMLize and send the message in the current buffer.