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

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

;; Copyright (C) 2021  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 'eww)

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


;; Moving messages around

(defvar jao-notmuch-mailboxes nil)
(defvar jao-notmuch-mailboxes-rx nil)

(defun jao-notmuch--path-to-mailbox (full-path)
  (unless jao-notmuch-mailboxes-rx
    (setq jao-notmuch-mailboxes-rx (regexp-opt jao-notmuch-mailboxes)))
  (if (string-match jao-notmuch-mailboxes-rx full-path)
      (match-string 0 full-path)
    (user-error "Message not in any registered mailbox!")))

(defun jao-notmuch--msg-props ()
  (if-let ((p (save-excursion
                (beginning-of-line)
                (text-property-search-forward :notmuch-message-properties))))
      (prop-match-value p)
    (user-error "No message at point")))

(defun jao-notmuch--full-path ()
  (seq-find #'file-exists-p (plist-get (jao-notmuch--msg-props) :filename)))

(defun jao-notmuch--move (&optional full-path d)
  (let* ((full-path (or full-path (jao-notmuch--full-path)))
         (ff (jao-notmuch--path-to-mailbox full-path))
         (d (or d (completing-read (format "From %s to: " ff)
                                   (remove ff jao-notmuch-mailboxes) nil t)))
         (dest (string-replace ff d full-path))
         (dest (replace-regexp-in-string ",U=.+$" "m:2,S" dest))
         (ftags (split-string ff "/"))
         (ttags (split-string d "/")))
    (when (y-or-n-p (format "%s -> %s? " ftags ttags))
      (notmuch-tree-close-message-window)
      (notmuch-tree-tag (append (notmuch-tag-change-list ftags t)
                                (notmuch-tag-change-list ttags)))
      (rename-file (jao-notmuch--full-path) dest)
      (shell-command-to-string "notmuch new")
      (notmuch-refresh-this-buffer))))

(defun jao-notmuch-move-message ()
  "Move message at point to another folder."
  (interactive)
  (jao-notmuch--move))


;; Targetting the displayed message from the tree view

(defvar-local jao-notmuch--tree-buffer nil)

(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-goto-tree-buffer (&optional no-record)
  (interactive)
  (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-scroll-or-next ()
  "Scroll or next message in forest or exit if none."
  (interactive)
  (if (notmuch-tree-scroll-message-window)
      (notmuch-tree-next-matching-message t)
    (when (not (window-live-p notmuch-tree-message-window))
      (notmuch-tree-show-message nil)))
  (jao-notmuch--tree-update-buffer-name))

(defun jao-notmuch-tree-show-or-scroll ()
  "Show current message, or scroll it if visible."
  (interactive)
  (if (window-live-p notmuch-tree-message-window)
      (scroll-other-window 1)
    (notmuch-tree-show-message nil)
    (jao-notmuch--tree-update-buffer-name)))

(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-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)
    (forward-button 1)))

(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))
    (backward-button 1)))

(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)))
          (add-to-list 'res url t)))
      res)))

(defun jao-notmuch-browse-urls (&optional external)
  (interactive "P")
  (when (or (derived-mode-p 'notmuch-show-mode)
            (jao-notmuch-goto-message-buffer))
    (let ((urls (jao-notmuch--page-urls (notmuch-show--gather-urls)))
          (fn (if external browse-url-secondary-browser-function #'browse-url)))
      (if urls
          (funcall fn (completing-read "Browse URL: " urls))
        (message "No URLs in this message")))))


;; 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--show-hidden-html ()
  (when (save-excursion
          (goto-char (point-min))
          (re-search-forward "^\\[ text/html (hidden) \\]" nil t))
    (jao-notmuch--toggle-mime)))

(defun jao-notmuch-show-prefer-html ()
  (add-hook 'notmuch-show-hook #'jao-notmuch--show-hidden-html))

(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)
    (jao-notmuch--tree-update-buffer-name)))

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

(defun jao-notmuch--setup-w3m-images (&optional activate)
  (setq-local w3m-ignored-image-url-regexp
              (unless jao-notmuch--showing-images
                notmuch-show-text/html-blocked-images))
  (when activate
    (w3m-toggle-inline-images (if jao-notmuch--showing-images t 'turnoff))))

(defun jao-notmuch-show-images ()
  (interactive)
  (save-window-excursion
    (when (and (jao-notmuch-goto-message-buffer nil t)
               (derived-mode-p 'notmuch-show-mode))
      (goto-char (point-min))
      (when (re-search-forward "^\\[ text/html " nil t)
        (when (looking-at-p "(hidden)")
          (notmuch-show-toggle-part-invisibility))
        (forward-line 1)
        (setq jao-notmuch--showing-images (not jao-notmuch--showing-images))
        (jao-notmuch--setup-w3m-images t)))))

(add-hook 'notmuch-show-mode-hook #'jao-notmuch--setup-w3m-images)

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


;; Keeping track of unread messages in current tree view

(defvar-local jao-notmuch--query-name nil)

(defun jao-notmuch--query-name ()
  (when notmuch-tree-basic-query
    (or jao-notmuch--query-name
        (setq jao-notmuch--query-name
              (let ((q (seq-find (lambda (q)
                                   (string= (or (plist-get q :query) "")
                                            notmuch-tree-basic-query))
                                 notmuch-saved-searches)))
                (or (plist-get q :name)  notmuch-tree-basic-query))))))

(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))))

(defun jao-notmuch--unread-count ()
  (save-excursion
    (goto-char (point-min))
    (let ((p) (cnt) (total))
      (while (setq p (text-property-search-forward :notmuch-message-properties))
        (unless cnt (setq cnt 0 total 0))
        (setq total (1+ total))
        (when (jao-notmuch--looking-at-new-p (prop-match-value p))
          (setq cnt (1+ cnt))))
      (when cnt (format "%s / %s messages" cnt total)))))

(defun jao-notmuch--tree-update-buffer-name (&optional n)
  (when-let ((n (or n (jao-notmuch--unread-count))))
    (rename-buffer (format "%s - %s" (jao-notmuch--query-name) n))
    (jao-minibuffer-refresh)))

(defun jao-notmuch--tree-sentinel (proc &rest _)
  (let ((buffer (process-buffer proc))
        (status (process-status proc)))
    (when (and (eq status 'exit) (buffer-live-p buffer))
      (with-current-buffer buffer (jao-notmuch--tree-update-buffer-name)))))

(advice-add 'notmuch-tree-process-sentinel :after #'jao-notmuch--tree-sentinel)

(defun jao-notmuch-echo-count ()
  "Show the number of unread messages left in this tree view."
  (interactive)
  (when-let ((n (jao-notmuch--unread-count)))
    (jao-notmuch--tree-update-buffer-name n)
    (message n)))

(defun jao-notmuch-tree-next (thread &optional no-exit)
  "Next message or thread in forest or exit if none."
  (interactive "P")
  (if thread
      (progn (notmuch-tree-next-thread)
             (unless (jao-notmuch--looking-at-new-p)
               (notmuch-tree-next-matching-message (not no-exit)))
             (notmuch-tree-show-message nil))
    (notmuch-tree-next-matching-message (not no-exit)))
  (jao-notmuch--tree-update-buffer-name))

;; Tagging

(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-and-next (tags reverse whole-thread)
  (let ((c (notmuch-tag-change-list tags reverse)))
    (if whole-thread (notmuch-tree-tag-thread c) (notmuch-tree-tag c)))
  (jao-notmuch-tree-next whole-thread t))

(defun jao-notmuch-tree-delete-message (undelete)
  (interactive "P")
  (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undelete nil))

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

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

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

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


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