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

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

;; Copyright (C) 2021, 2022, 2023, 2024, 2025, 2026  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/>.

;; Extensions to vanilla notmuch, mostly for tree view

;;; require:

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

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


;;; searches
(defvar jao-notmuch--new nil)
(defvar jao-notmuch--new-rx nil)
(defvar jao-notmuch--newa nil)

(defun jao-notmuch--tags-q (tags)
  (format "tag:\"/^(%s)$/\"" (mapconcat (lambda (s) (format "%s" s)) tags "|")))

(defun jao-notmuch--new (&rest tags)
  (cond ((listp jao-notmuch--new)
         (jao-notmuch--tags-q (append jao-notmuch--new tags)))
        (tags (concat jao-notmuch--new " OR " (jao-notmuch--tags-q tags)))
        (t jao-notmuch--new)))

(defun jao-notmuch--set-new-search (s)
  (setq jao-notmuch--new s
        jao-notmuch--new-rx (regexp-quote (jao-notmuch--new))
        jao-notmuch--newa (concat (jao-notmuch--new) " AND ")))

(defun jao-notmuch--q (d0 &optional k d1 qs st)
  (let* ((qs (when qs (mapconcat (lambda (q) (format "%s" q)) qs " AND ")))
         (q (or qs
                (concat (jao-notmuch--new)
                        (mapconcat (lambda (d) (when d (concat " AND tag:" d)))
                                   (list d0 d1))))))
    (list :name (concat d0 (when (and d1 (not (string= "" d1))) "/") d1)
          :key k :query q :search-type (or st 'tree)
          :sort-order 'oldest-first)))

(defun jao-notmuch--q-feed (q)
  (apply #'jao-notmuch--q (cons "feeds" q)))

;;;###autoload
(defun jao-notmuch-init-searches (s &optional other)
  (jao-notmuch--set-new-search s)

  (setq notmuch-hello-sections nil
        notmuch-saved-searches nil
        jao-notmuch-widened-searches nil)

  (when other (jao-notmuch-def-searches (car other) (cdr other))))

;;;###autoload
(defun jao-notmuch-tree-widen-search ()
  (interactive)
  (when-let* ((query (notmuch-tree-get-query)))
    (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto)))
      (notmuch-tree-close-message-window)
      (notmuch-tree (string-replace jao-notmuch--newa "" query)))))

(defun jao-notmuch--widen (s &optional extra)
  (let* ((q (plist-get s :query))
         (qs (string-replace jao-notmuch--newa "" q)))
    (plist-put (copy-sequence s) :query (concat qs extra))))

;;;###autoload
(defun jao-notmuch-widen-searches (searches &optional extra)
  (mapcar (lambda (s) (jao-notmuch--widen s extra)) searches))

(defun jao-notmuch-hello--insert-searches (searches title title-face)
  (when-let* ((searches (notmuch-hello-query-counts searches)))
    (let* ((cnt (when title
                  (seq-reduce (lambda (c q)
                                (+ c (or (plist-get q :count) 0)))
                              searches
                              0)))
           (title (when title (format "%d %s" cnt title)))
           (notmuch-column-control 1.0)
           (title-face (or title-face 'jao-themes-f00)))
      (when title
        (widget-insert (propertize title 'face title-face))
        (newline)
        (jao-notmuch-hbar 5))
      (notmuch-hello-insert-buttons searches)
      (newline))))

(defun jao-notmuch--replace (lst s)
  (let ((name (plist-get s :name)))
    (set lst (seq-remove (lambda (s0) (string= name (plist-get s0 :name)))
                         (symbol-value lst)))
    (add-to-list lst s t)))

;;;###autoload
(defun jao-notmuch-def-searches (name searches &optional no-save title-face)
  (declare (indent 1))
  (unless no-save
    (dolist (s searches)
      (jao-notmuch--replace 'jao-notmuch-widened-searches
                            (jao-notmuch--widen s))
      (jao-notmuch--replace 'notmuch-saved-searches s)))
  (add-to-list 'notmuch-hello-sections
               `(jao-notmuch-hello--insert-searches ,searches ,name ,title-face)
               t))

(defvar jao-notmuch-widened-searches nil)

;;; jump to searches
(defun jao-notmuch--searches-w/new (searches)
  (seq-filter (lambda (s)
                (string-match-p jao-notmuch--new-rx (plist-get s :query)))
              (notmuch-hello-query-counts searches)))

(defconst jao-notmuch--search-keys '("a" "s" "d" "f" "g" "h" "j" "k" "l"))

(defun jao-notmuch--index-searches (searches)
  (seq-map-indexed (lambda (q i)
                     (plist-put q :key (or (elt jao-notmuch--search-keys i)
                                           (format "%s" i))))
                   searches))

;;;###autoload
(defun jao-notmuch-jump-search (&optional widen)
  (interactive "P")
  (let ((notmuch-saved-searches
         (if widen jao-notmuch-widened-searches notmuch-saved-searches)))
    (notmuch-jump-search)))

;;;###autoload
(defun jao-notmuch-jump ()
  "Jump to a saved, non-zero count search."
  (interactive)
  (if-let* ((searches (jao-notmuch--searches-w/new notmuch-saved-searches)))
      (if (= 2 (length searches))
          (let* ((q (seq-remove (lambda (q) (string= "new" (plist-get q :name)))
                                searches))
                 (q (car q))
                 (of (eq 'oldest-first (plist-get q :sort-order)))
                 (query (plist-get q :query)))
            (notmuch-tree query nil nil nil nil nil nil of t))
        (let ((notmuch-saved-searches (jao-notmuch--index-searches searches)))
          (notmuch-jump-search)))
    (jao-notmuch-jump-search t)))

;;; targetting the displayed message from the tree view

(defvar-local jao-notmuch--tree-buffer nil)
(declare-function 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-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)
        (notmuch-tree-outline-next)
      (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 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 ()
  (require 'eww)
  (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 ((memq mm-text-html-renderer '(w3m jao-w3m-html-renderer))
         (when (fboundp 'jao-notmuch--w3m-toggle-images)
           (jao-notmuch--w3m-toggle-images)))
        (window-system (jao-notmuch--shr-toggle-images))
        (notmuch-tree-message-buffer
         (if nil ;;(fboundp 'jao-open-in-x-frame)
             (let ((w (get-buffer-window notmuch-tree-message-buffer)))
               (jao-open-in-x-frame (window-width w) (window-height w))
               (jao-notmuch--shr-toggle-images)
               (delete-window))
           (with-current-buffer notmuch-tree-message-buffer
             (jao-notmuch--view-html))))))

;;; header and mode lines with thread message counts

(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 (tree-buffer &optional thread)
  (with-current-buffer tree-buffer
    (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--format-header-line (tree-buffer buffer subject)
  (let* ((n (jao-notmuch--message-counts tree-buffer))
         (nc (jao-notmuch--message-counts tree-buffer t)))
    (with-current-buffer buffer
      (when (derived-mode-p 'notmuch-show-mode)
        (let* ((nc (append (or n '(0 0 0)) (or nc '(0 0 0))))
               (q (if (string= tree-buffer subject) "" tree-buffer))
               (c (apply 'jao-notmuch--format-counts q nc))
               (n (- (window-width) 2 (string-width subject) (string-width c)))
               (subject (if (< n 0) (substring subject 0 n) subject))
               (n (if (< n 0) 2 (+ n 2))))
          (concat (when window-system " ") subject (make-string n ? ) c))))))

(defun jao-notmuch-message-header-line (subject)
  (if-let* ((cb (buffer-name (current-buffer)))
            (tb (seq-find (lambda (b)
                            (with-current-buffer b
                              (and (derived-mode-p 'notmuch-tree-mode) b)))
                          (buffer-list))))
      `((:eval
         (jao-notmuch--format-header-line ,(buffer-name tb) ,cb ,subject)))
    (concat " " subject)))

(defun jao-notmuch--format-lighter ()
  (when (derived-mode-p 'notmuch-tree-mode)
    (let* ((n (jao-notmuch--message-counts (current-buffer)))
           (nc (jao-notmuch--message-counts (current-buffer) t))
           (nc (append (or n '(0 0 0)) (or nc '(0 0 0)))))
      (apply 'jao-notmuch--format-counts "" nc))))

(define-minor-mode jao-notmuch-thread-info-mode ""
  :lighter (:eval (format " %s" (jao-notmuch--format-lighter))))


;;; tagging

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

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

(defun jao-notmuch-tree-tag-thread (tags reverse full)
  (when full (notmuch-tree-thread-top))
  (let ((c (notmuch-tag-change-list tags reverse))
        (level (or (notmuch-tree-get-prop :level) 0))
        (go t))
    (while go
      (notmuch-tree-tag c)
      (forward-line)
      (setq go (> (or (notmuch-tree-get-prop :level) 0) level)))
    (when notmuch-tree-outline-mode
      (ignore-errors (outline-show-branches))
      (notmuch-tree-outline-next))))

(defun jao-notmuch-tree--tag-and-next (tags reverse)
  (jao-notmuch-tree--tag tags reverse)
  (notmuch-tree-outline-next 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)))

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

(defun jao-notmuch-tree-mark-all-read ()
  (interactive)
  (when-let* ((q notmuch-tree-basic-query))
    (when (yes-or-no-p "Mark all messages as read? ")
      (notmuch-tag q '("-new" "-unread")))))

(defun jao-notmuch-tree-read-thread (full)
  (interactive "P")
  (jao-notmuch-tree-tag-thread '("-unread" "-new") nil full))

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

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

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

(defvar jao-notmuch--shared-tags
  '("new" "unread" "flagged" "signed" "sent" "attachment" "forwarded" "inbox"
    "encrypted" "gmane" "gnus" "feeds" "rss" "mce" "trove" "prog" "emacs"))

(defun jao-notmuch-subtags (tag &rest excl)
  (let* ((cmd (concat "notmuch search --output=tags tag:" tag))
         (ts (split-string (shell-command-to-string cmd))))
    (seq-difference ts (append jao-notmuch--shared-tags (cons tag excl)))))

;;; fcc
(defvar jao-notmuch-tags-not-inherited
  '("attachment" "sent" "new" "trove" "flagged" "drivel" "replied"))

(defvar jao-notmuch-sent-dir "sent")

(defun jao-notmuch-mua--inherited-fcc ()
  (let* ((tags (seq-difference (notmuch-show-get-tags)
                               jao-notmuch-tags-not-inherited))
         (tagstr (mapconcat (lambda (s) (concat "+" s)) tags " "))
         (fcc (concat jao-notmuch-sent-dir " " tagstr " -new +sent"))
         (fcc-dirs (assoc-delete-all ".*" (copy-alist notmuch-fcc-dirs))))
    (append fcc-dirs `((".*" . ,fcc)))))

(defun jao-notmuch-mua-new-reply (fun &rest args)
  (let ((notmuch-fcc-dirs (jao-notmuch-mua--inherited-fcc)))
    (apply fun args)))

(advice-add 'notmuch-mua-new-reply :around #'jao-notmuch-mua-new-reply)

;;; results formatters

(defun jao-notmuch-cmp-tags (a b)
  (or (> (length a) (length b)) (string-lessp a b)))

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

(defun jao-notmuch-format-authors (threshold msg)
  (let ((fmt (if (< (window-width) threshold) "%-15s" "%-35s")))
    (notmuch-tree-format-field "authors" fmt msg)))

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

(defun jao-notmuch-format-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)
;;; bars
(defun jao-notmuch-hbar (margin)
  (widget-insert (propertize (make-string (- (window-width) margin) ?—)
                             'face '(:foreground "grey80")))
  (newline))
;;; org links
(defun jao-notmuch-id-file-name (id)
  (let ((cmd (format "notmuch search --output=files id:%s" id)))
    (car (split-string (shell-command-to-string cmd)))))

(defun jao-notmuch-org-store ()
  (when-let* ((d (and (derived-mode-p '(notmuch-show-mode notmuch-tree-mode))
                      (cons (notmuch-show-get-message-id)
                            (notmuch-show-get-subject)))))
    (org-link-store-props :type "mail"
                          :link (concat "mail:" (car d))
                          :description (concat "Mail: " (cdr d)))))

(defun jao-notmuch-org-links ()
  (org-link-set-parameters "mail"
                           :follow #'notmuch-show
                           :store #'jao-notmuch-org-store)
  (org-link-set-parameters "gnus" :store #'ignore)
  (org-link-set-parameters "notmuch" :store #'ignore))

;;; jao-notmuch.el ends here