;;; 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