path: root/lib/net/jao-notmuch.el

;;; jao-notmuch.el --- Extensions for notmuch        -*- lexical-binding: t; -*-

;; Copyright (C) 2021, 2022  jao

;; Author: jao <mail@jao.io>
;; Keywords: mail

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;  Extensions to vanilla notmuch, mostly for tree view

;;; Code:

(require 'outline)
(require 'mm-decode)
(require 'mm-view)

(require 'notmuch)
(require 'notmuch-tree)
(require 'notmuch-show)


;;;; Targetting the displayed message from the tree view

(defvar-local jao-notmuch--tree-buffer nil)
(declare eww--url-at-point "eww")

(defun jao-notmuch-goto-message-buffer (&optional and-click no-record)
  (interactive "P")
  (when (window-live-p notmuch-tree-message-window)
    (let ((b (current-buffer)))
      (select-window notmuch-tree-message-window no-record)
      (setq-local jao-notmuch--tree-buffer b)
      (or (not and-click)
          (cond ((eww--url-at-point) (shr-browse-url) 'url)
                ((button-at (point)) (push-button) 'button))))))

(defun jao-notmuch-tree-toggle-message ()
  (interactive)
  (if (window-live-p notmuch-tree-message-window)
      (notmuch-tree-close-message-window)
    (notmuch-tree-show-message nil)))

(defun jao-notmuch-click-message-buffer ()
  (interactive)
  (let ((b (current-buffer)))
    (unless (eq 'url (jao-notmuch-goto-message-buffer t t))
      (pop-to-buffer b))))

(defun jao-notmuch-tree--find-tree-buffer ()
  (or jao-notmuch--tree-buffer
      (let ((mb (current-buffer)))
        (seq-find (lambda (b)
                    (with-current-buffer b
                      (and (derived-mode-p 'notmuch-tree-mode)
                           (eq notmuch-tree-message-buffer mb))))
                  (buffer-list)))))

(defun jao-notmuch-goto-tree-buffer (&optional no-record)
  (interactive)
  (setq jao-notmuch--tree-buffer (jao-notmuch-tree--find-tree-buffer))
  (if (buffer-live-p jao-notmuch--tree-buffer)
      (pop-to-buffer jao-notmuch--tree-buffer nil no-record)
    (user-error "No tree view for this buffer")))

(defun jao-notmuch-tree--looking-at-message ()
  (when-let (id (plist-get (notmuch-tree-get-message-properties) :id))
    (equal (concat "*notmuch-id:" id "*")
           (buffer-name (window-buffer notmuch-tree-message-window)))))

(defun jao-notmuch-tree-scroll-or-next ()
  "Scroll or next message in forest or exit if none."
  (interactive)
  (if (not (jao-notmuch-tree--looking-at-message))
      (jao-notmuch-tree-show-or-scroll t)
    (if (notmuch-tree-scroll-message-window)
        (jao-notmuch-tree-next nil)
      (when (not (window-live-p notmuch-tree-message-window))
        (notmuch-tree-show-message nil)))))

(defun jao-notmuch-tree-show-or-scroll (force)
  "Show current message, or scroll it if visible."
  (interactive "P")
  (if (and (not force)
           (window-live-p notmuch-tree-message-window)
           (jao-notmuch-tree--looking-at-message))
      (scroll-other-window 1)
    (notmuch-tree-show-message nil)))

(notmuch-tree--define-do-in-message-window
 jao-notmuch-tree-end-of-buffer
 end-of-buffer)

(notmuch-tree--define-do-in-message-window
 jao-notmuch-tree-beginning-of-buffer
 beginning-of-buffer)

(defun jao-notmuch--page-urls (res)
  (save-excursion
    (goto-char (point-min))
    (let ((pos (point)))
      (while (setq pos (next-single-property-change pos 'w3m-href-anchor))
        (when-let ((url (get-text-property pos 'w3m-href-anchor)))
          (when (stringp url) (cl-pushnew url res :test #'string=))))
      (seq-uniq res #'string=))))

(defun jao-notmuch-message-urls ()
  (save-window-excursion
    (when (or (derived-mode-p 'notmuch-show-mode)
              (jao-notmuch-goto-message-buffer))
      (jao-notmuch--page-urls (notmuch-show--gather-urls)))))

(defun jao-notmuch-browse-urls (&optional external)
  (interactive "P")
  (if-let ((urls (jao-notmuch-message-urls)))
      (funcall (if external browse-url-secondary-browser-function #'browse-url)
               (completing-read "Browse URL: " urls))
    (message "No URLs in this message")))


;;;; Navigating URLs

(require 'ffap)

(defun jao-notmuch-show-next-button ()
  (interactive)
  (when (get-text-property (point) 'w3m-href-anchor)
    (goto-char (next-single-property-change (point) 'w3m-href-anchor)))
  (if-let (pos (next-single-property-change (point) 'w3m-href-anchor))
      (goto-char pos)
    (or (forward-button 1 nil t t)
        (ffap-next-guess))))

(defun jao-notmuch-show-previous-button ()
  (interactive)
  (if-let (pos (previous-single-property-change (point) 'w3m-href-anchor))
      (goto-char (previous-single-property-change pos 'w3m-href-anchor))
    (or (backward-button 1 nil t t)
        (ffap-next-guess t))))

(defun jao-notmuch-show-ret ()
  (interactive)
  (when-let (url (or (get-text-property (point) 'w3m-href-anchor)
                     (thing-at-point-url-at-point)))
    (browse-url url)))


;;;; Toggling mime parts and images

(defun jao-notmuch--toggle-mime ()
  (save-excursion
    (goto-char (point-min))
    (while (and (re-search-forward "^\\[ text/\\(html\\|plain\\) " nil t)
                (button-at (point)))
      (notmuch-show-toggle-part-invisibility))))

(defun jao-notmuch-toggle-mime-parts ()
  (interactive)
  (when (jao-notmuch-goto-message-buffer nil t)
    (goto-char (point-min))
    (jao-notmuch--toggle-mime)
    (jao-notmuch-goto-tree-buffer t)))

(defun jao-notmuch--view-html ()
  "Open the text/html part of the current message using `notmuch-show-view-part'."
  (interactive)
  (save-excursion
    (goto-char
     (prop-match-beginning
      (text-property-search-forward
       :notmuch-part
       "text/html"
       (lambda (value notmuch-part)
         (equal (plist-get notmuch-part :content-type)
                value)))))
    (notmuch-show-view-part)))

(defvar-local jao-notmuch--showing-images nil)

(defun jao-notmuch--shr-toggle-images ()
  (let* ((b notmuch-tree-message-buffer)
         (show (not (buffer-local-value 'jao-notmuch--showing-images b)))
         (mm-text-html-renderer 'shr)
         (shr-blocked-images (unless show shr-blocked-images))
         (shr-inhibit-images (not show))
         (notmuch-show-text/html-blocked-images
          (unless show notmuch-show-text/html-blocked-images))
         (notmuch-multipart/alternative-discouraged
          (if show '("text/plain") notmuch-multipart/alternative-discouraged)))
    (notmuch-tree-close-message-window)
    (notmuch-tree-show-message nil)
    (with-current-buffer notmuch-tree-message-buffer
      (setq jao-notmuch--showing-images show))))

(defun jao-notmuch-toggle-images ()
  (interactive)
  (cond ((eq mm-text-html-renderer 'w3m)
          (when (fboundp 'jao-notmuch--w3m-toggle-images)
            (jao-notmuch--w3m-toggle-images)))
        (window-system (jao-notmuch--shr-toggle-images))
        (t (with-current-buffer notmuch-tree-message-buffer
             (jao-notmuch--view-html)))))


;;;; Keeping track of unread messages in current tree view

(defun jao-notmuch--looking-at-new-p (&optional p)
  (when-let (ts (if p (plist-get p :tags) (notmuch-show-get-tags)))
    (or (member "unread" ts) (member "new" ts))))

(defsubst jao-notmuch-tree--first-p (&optional msg)
  (plist-get (or msg (notmuch-tree-get-message-properties)) :first))

(defun jao-notmuch--message-counts (&optional thread)
  (let ((cnt) (total 0) (match 0) (msg))
    (save-excursion
      (if thread
          (while (and (not (jao-notmuch-tree--first-p))
                      (zerop (forward-line -1))))
        (goto-char (point-min)))
      (while (and (setq msg (notmuch-tree-get-message-properties))
                  (or (not cnt)
                      (not thread)
                      (not (jao-notmuch-tree--first-p msg))))
        (unless cnt (setq cnt 0))
        (setq total (1+ total))
        (when (plist-get msg :match) (setq match (1+ match)))
        (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt)))
        (forward-line 1)))
    (when cnt (list total match cnt))))

(defvar jao-notmuch-header-line-format "%Q  [%N / %M / %T] %n / %m / %t")

(defun jao-notmuch--format-counts (query total match new ttotal tmatch tnew)
  (format-spec jao-notmuch-header-line-format
               `((?Q . ,query) (?T . ,total) (?N . ,new) (?M . ,match)
                 (?t . ,ttotal) (?n . ,tnew) (?m . ,tmatch))))

(defun jao-notmuch--update-header-line (mb)
  (let* ((n (or (jao-notmuch--message-counts) '(0 0 0)))
         (nc (append n (or (jao-notmuch--message-counts t) '(0 0 0))))
         (q (buffer-name)))
    (with-current-buffer mb
      (when (derived-mode-p 'notmuch-show-mode)
        (let* ((s (thread-last (notmuch-show-get-subject)
                               (notmuch-show-strip-re)
                               (notmuch-sanitize)))
               (c (apply 'jao-notmuch--format-counts q nc))
               (n (- (window-width) 3 (string-width s) (string-width c)))
               (s (if (< n 0) (substring s 0 (- n 4)) s))
               (n (if (< n 0) 5 (1+ n))))
          (setq-local header-line-format
                      (concat " " s (make-string n ? ) c)))))))

(defun jao-notmuch-tree--find-update-header-line (&rest _args)
  (when-let ((mb (if (derived-mode-p 'notmuch-show-mode)
                     (current-buffer)
                   (window-buffer notmuch-tree-message-window))))
    (seq-find (lambda (b)
                (with-current-buffer b
                  (and (derived-mode-p 'notmuch-tree-mode)
                       (or (null notmuch-tree-message-buffer)
                           (eq notmuch-tree-message-buffer mb))
                       (jao-notmuch--update-header-line mb))))
              (buffer-list))))

(add-hook 'notmuch-after-tag-hook #'jao-notmuch-tree--find-update-header-line)
(add-hook 'notmuch-show-hook #'jao-notmuch-tree--find-update-header-line)


;;;; Outline mode for tree view

(defun jao-notmuch-tree--msg-prefix (msg)
  (insert (propertize (if (plist-get msg :first) "> " "  ") 'display " ")))

(defun jao-notmuch-tree--mode-setup ()
  (setq-local outline-regexp "^> \\|^En")
  (outline-minor-mode t))

(defun jao-notmuch-tree-hide-others (&optional and-show)
  (interactive)
  (outline-hide-body)
  (outline-show-entry)
  (when and-show (notmuch-tree-show-message nil)))

(defun jao-notmuch-tree--next (prev thread no-exit &optional ignore-new)
  (let ((line-move-ignore-invisible nil))
    (cond ((and (not ignore-new) (jao-notmuch--looking-at-new-p)))
          (thread
           (notmuch-tree-next-thread prev)
           (unless (or (not (notmuch-tree-get-message-properties))
                       (jao-notmuch--looking-at-new-p))
             (notmuch-tree-matching-message prev (not no-exit))))
          (t (notmuch-tree-matching-message prev (not no-exit)))))
  (when (notmuch-tree-get-message-id)
    (jao-notmuch-tree-hide-others t))
  (when prev (forward-char 2)))

(defvar jao-notmuch-tree--prefix-map
  (let ((m (make-keymap "Thread operations")))
    (define-key m (kbd "TAB") #'outline-cycle)
    (define-key m (kbd "t") #'outline-toggle-children)
    (define-key m (kbd "s") #'outline-show-entry)
    (define-key m (kbd "S") #'outline-show-all)
    (define-key m (kbd "h") #'outline-hide-entry)
    (define-key m (kbd "H") #'outline-hide-body)
    (define-key m (kbd "o") #'jao-notmuch-tree-hide-others)
    (define-key m (kbd "n") #'outline-hide-other)
    m))

(defun jao-notmuch-tree-outline-setup (&optional prefix)
  (define-key notmuch-tree-mode-map (kbd (or prefix "T"))
    jao-notmuch-tree--prefix-map)
  (define-key notmuch-tree-mode-map (kbd "TAB") #'outline-cycle)
  (define-key notmuch-tree-mode-map (kbd "M-TAB") #'outline-cycle-buffer)
  (add-hook 'notmuch-tree-mode-hook #'jao-notmuch-tree--mode-setup)
  (advice-add 'notmuch-tree-insert-msg :before #'jao-notmuch-tree--msg-prefix))

(defun jao-notmuch-tree-next (thread &optional no-exit)
  "Next message or thread in forest, taking care of thread visibility."
  (interactive "P")
  (jao-notmuch-tree--next nil thread no-exit))

(defun jao-notmuch-tree-next-thread (&optional exit)
  "Next thread in forest, taking care of thread visibility."
  (interactive "P")
  (jao-notmuch-tree--next nil t exit))

(defun jao-notmuch-tree-previous (thread)
  "Previous message or thread in forest, taking care of thread visibility."
  (interactive "P")
  (jao-notmuch-tree--next t thread t))

(defun jao-notmuch-tree-previous-thread (&optional exit)
  "Previous thread in forest, taking care of thread visibility."
  (interactive "P")
  (jao-notmuch-tree--next t t exit))


;;;; Updating the tree window after insertion

(defun jao-notmuch--tree-sentinel (proc &rest _)
  (when (eq (process-status proc) 'exit)
    (jao-notmuch-tree-hide-others)))

(defun jao-notmuch-tree-setup (&optional prefix)
  "Set up display of trees, with PREFIX key for outline commands."
  (jao-notmuch-tree-outline-setup prefix)
  (advice-add 'notmuch-tree-process-sentinel :after #'jao-notmuch--tree-sentinel))


;;;; Tagging

(defsubst jao-notmuch--has-tag (tag)
  (member tag (notmuch-tree-get-tags)))

(defun jao-notmuch-tag-jump-and-next (reverse)
  (interactive "P")
  (notmuch-tag-jump reverse)
  (jao-notmuch-tree-next nil t))

(defun jao-notmuch-tree--tag (tags reverse whole-thread)
  (let ((c (notmuch-tag-change-list tags reverse)))
    (if whole-thread (notmuch-tree-tag-thread c) (notmuch-tree-tag c))))

(defun jao-notmuch-tree--tag-and-next (tags reverse whole-thread)
  (jao-notmuch-tree--tag tags reverse whole-thread)
  (jao-notmuch-tree-next whole-thread t))

(defun jao-notmuch-tree-toggle-delete ()
  (interactive)
  (let ((undo (jao-notmuch--has-tag "deleted")))
    (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo nil)))

(defun jao-notmuch-tree-toggle-delete-thread ()
  (interactive)
  (let ((undo (jao-notmuch--has-tag "deleted")))
    (jao-notmuch-tree--tag-and-next '("+deleted" "-new"  "-unread") undo t)))

(defun jao-notmuch-tree-read-thread (unread)
  (interactive "P")
  (jao-notmuch-tree--tag-and-next '("-unread" "-new") unread t))

(defun jao-notmuch-tree-toggle-flag ()
  (interactive)
  (let ((tags (if (jao-notmuch--has-tag "flagged")
                  '("-flagged")
                '("-unread" "-new" "-deleted" "+flagged"))))
    (jao-notmuch-tree--tag-and-next tags nil nil)))

(defun jao-notmuch-tree-toggle-spam ()
  (interactive)
  (let ((tags (if (jao-notmuch--has-tag "spam")
                  '("-spam")
                '("-unread" "-new" "+spam"))))
    (jao-notmuch-tree--tag-and-next tags nil nil)))

(defun jao-notmuch-tree-reset-tags ()
  (interactive)
  (let ((tags (plist-get (notmuch-tree-get-message-properties) :orig-tags)))
    (jao-notmuch-tree--tag tags nil nil)
    (jao-notmuch-tree--next nil nil t t)))


;;;; Results formatters

(defun jao-notmuch-format-tags (fmt msg)
  (let ((ts (thread-last (notmuch-tree-format-field "tags" "%s" msg)
              (split-string)
              (seq-sort-by #'length #'<))))
    (format-spec fmt `((?s . ,(mapconcat #'identity ts " "))))))

(defun jao-notmuch-tree-and-subject (fmt msg)
  (let ((tr (notmuch-tree-format-field "tree" " %s" msg))
        (sb (notmuch-tree-format-field "subject" " %s" msg)))
    (format-spec fmt `((?s . ,(concat tr sb))))))

(defun jao-notmuch-msg-ticks (mails-rx msg)
  (let ((headers (plist-get msg :headers)))
    (cond ((string-match-p mails-rx (or (plist-get headers :To) ""))
           (propertize " »" 'face 'notmuch-tree-match-tree-face))
          ((string-match-p mails-rx (or (plist-get headers :Cc) ""))
           (propertize " ¬" 'face 'notmuch-tree-match-tree-face))
          (t "  "))))

(provide 'jao-notmuch)
;;; jao-notmuch.el ends here