;;; jao-notmuch-gnus.el --- notmuch-gnus interoperability -*- lexical-binding: t; -*- ;; Copyright (C) 2022, 2024 jao ;; Author: jao ;; 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 . ;;; Commentary: ;; Helper functions to work in Gnus with mail indexed by notmuch. ;;; Code: (require 'gnus) (require 'ol-gnus) (require 'notmuch-show) ;;; Tagging in notmuch from Gnus buffers (defun jao-notmuch-gnus--notmuch-id (id) (when id (if (string-match "<\\(.+\\)>" id) (match-string 1 id) id))) (defun jao-notmuch-gnus-message-id (&optional no-show) "Find the id of currently selected message in Gnus or notmuch." (when (and (not no-show) (derived-mode-p 'gnus-summary-mode)) (save-window-excursion (gnus-summary-show-article))) (cond (gnus-original-article-buffer (with-current-buffer gnus-original-article-buffer (jao-notmuch-gnus--notmuch-id (message-field-value "message-id")))) ((derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode) (notmuch-show-get-message-id)))) (defun jao-notmuch-gnus-message-tags (id) "Ask notmuch for the tags of a message with the given ID." (let ((cmd (format "notmuch search --output=tags 'id:%s'" id))) (split-string (shell-command-to-string cmd)))) (defun jao-notmuch-gnus-tag-message (&optional id tags no-log) "Interactively add or remove tags to the current message." (interactive) (let* ((id (or id (jao-notmuch-gnus-message-id))) (current (unless tags (jao-notmuch-gnus-message-tags id))) (prompt (format "Change tags %s" (string-join current "/"))) (tags (or tags (notmuch-read-tag-changes current prompt)))) (notmuch-tag (concat "id:" id) tags) (unless no-log (message "%s -> %s" current (jao-notmuch-gnus-message-tags id))))) (defun jao-notmuch-gnus-show-tags () "Display in the echo area the tags of the current message." (interactive) (when-let* ((id (jao-notmuch-gnus-message-id))) (message "%s" (string-join (jao-notmuch-gnus-message-tags id) " ")))) (defun jao-notmuch-gnus-toggle-tags (tags &optional id current) "Toggle the given TAGS list for the current Gnus message." (let* ((id (or id (jao-notmuch-gnus-message-id))) (current (or current (jao-notmuch-gnus-message-tags id))) (tags (mapcar (lambda (x) (concat (if (member x current) "-" "+") x)) tags))) (notmuch-tag (concat "id:" id) tags) (message "New tags: %s" (jao-notmuch-gnus-message-tags id)))) (defun jao-notmuch-gnus-tag-mark () "Remove the new tag for an article when it's marked as seen by Gnus." (when-let* ((id (jao-notmuch-gnus-message-id t))) (jao-notmuch-gnus-tag-message id '("-new") t))) (add-hook 'gnus-mark-article-hook #'jao-notmuch-gnus-tag-mark) (defun jao-notmuch-gnus--group-tags (group) (when (string-match ".+:\\(.+\\)" group) (split-string (match-string 1 group) "\\."))) (defun jao-notmuch-gnus-tag-on-move (op headers from to _d) (when-let* ((to-tags (when to (jao-notmuch-gnus--group-tags to))) (id (jao-notmuch-gnus--notmuch-id (mail-header-id headers)))) (if (eq op 'delete) (let ((cur (seq-difference (jao-notmuch-gnus--group-tags from) to-tags))) (jao-notmuch-gnus-toggle-tags (append cur to-tags) id cur)) (notmuch-tag (concat "id:" id) (mapcar (lambda (x) (concat "+" x)) to-tags))))) (defun jao-notmuch-gnus-auto-tag () (add-hook 'gnus-summary-article-move-hook #'jao-notmuch-gnus-tag-on-move) (add-hook 'gnus-summary-article-expire-hook #'jao-notmuch-gnus-tag-on-move)) ;;; Gnus search using notmuch (require 'gnus-search) (add-to-list 'gnus-search-expandable-keys "list") (cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) (expr (head list))) (format "List:%s" (gnus-search-transform-expression engine (cdr expr)))) ;;; Displaying search results in Gnus (defvar jao-notmuch-gnus-server "nnml" "Name of the target Gnus server, e.g. nnml+mail.") (defvar jao-notmuch-gnus-mail-directory (expand-file-name "~/var/mail/gnus") "Directory where Gnus stores its mail.") (defvar jao-notmuch-gnus-leafnode-directory (expand-file-name "~/var/mail/news") "Directory where leafnode stores its messages as seen by notmuch.") (defun jao-notmuch-gnus-file-to-group (file &optional maildir newsdir) "Compute the Gnus group name from the given file name. Example: IN: /home/jao/var/mail/jao/foo/cur/1259184569.M4818P3384.localhost,W=6921:2,S OUT: nnml:jao.foo IN: /home/jao/.emacs.d/gnus/Mail/jao.trove/32, /home/jao/.emacs.d/gnus/Mail/ OUT: nnml:jao.trove IN: /home/jao/var/mail/gmane/foo/bar/100 OUT: nntp:gmane.foo.bar IN: /home/jao/var/mail/bigml/cur/1259176906.M17483P24679.localhost,W=2488:2,S OUT:nnimap:bigml/inbox" (let* ((maildir (or maildir jao-notmuch-gnus-mail-directory)) (newsdir (or newsdir jao-notmuch-gnus-leafnode-directory)) (g (directory-file-name (file-name-directory file))) (g (replace-regexp-in-string (file-name-as-directory maildir) "" g)) (g (replace-regexp-in-string (file-name-as-directory newsdir) "" g)) (nntp (string-match-p "^\\(gmane\\|gwene\\)/" g)) (g (cond (nntp (concat "nntp:" g)) ((file-name-directory g) (replace-regexp-in-string "^\\([^/]+\\)/" (concat jao-notmuch-gnus-server ":\\1/") (file-name-directory g) t)) (t (concat jao-notmuch-gnus-server ":" g)))) (g (replace-regexp-in-string "/" "." g)) (g (replace-regexp-in-string "[/.]$" "" g))) (cond ((string-match ":$" g) (concat g "inbox")) (nntp g) (t (replace-regexp-in-string ":\\." ":" g))))) (defun jao-notmuch-gnus-id-to-file (id) (when id (let ((cmd (format "notmuch search --output=files %s" id))) (string-trim (shell-command-to-string cmd))))) (defun jao-notmuch-gnus-goto-message (&optional msg-id filename) "Open a summary buffer containing the current notmuch article." (interactive) (let* ((filename (or filename (jao-notmuch-gnus-id-to-file msg-id) (notmuch-show-get-filename))) (group (when filename (jao-notmuch-gnus-file-to-group filename))) (msg-id (or msg-id (notmuch-show-get-message-id))) (msg-id (when msg-id (replace-regexp-in-string "^id:" "" msg-id)))) (if (and group msg-id) (org-gnus-follow-link group msg-id) (message "Couldn't get relevant infos for switching to Gnus.")))) (defun jao-notmuch-gnus-engine (prefix config) (let ((prefix (file-name-as-directory (expand-file-name prefix "~"))) (config (expand-file-name config gnus-home-directory))) `(gnus-search-engine gnus-search-notmuch (remove-prefix ,prefix) (config-file ,config)))) ;;; Org links (defun jao-notmuch-gnus--fname (id) (let ((cmd (format "notmuch search --output=files id:%s" id))) (car (split-string (shell-command-to-string cmd))))) (defun jao-notmuch-gnus-org-follow (id) (when-let* ((fname (jao-notmuch-gnus--fname id)) (group (jao-notmuch-gnus-file-to-group fname))) (org-gnus-follow-link group id))) (defun jao-notmuch-gnus-org-store () (when-let* ((d (or (when (derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode) (cons (notmuch-show-get-message-id) (notmuch-show-get-subject))) (when (derived-mode-p 'gnus-summary-mode 'gnus-article-mode) (cons (jao-notmuch-gnus-message-id) (gnus-summary-article-subject)))))) (org-link-store-props :type "mail" :link (concat "mail:" (car d)) :description (concat "Mail: " (cdr d))))) (org-link-set-parameters "mail" :follow #'jao-notmuch-gnus-org-follow :store #'jao-notmuch-gnus-org-store) (org-link-set-parameters "gnus" :store #'ignore) (org-link-set-parameters "notmuch" :store #'ignore) ;;; consult-notmuch (with-eval-after-load "consult-notmuch" (defun jao-notmuch-gnus--open-candidate (candidate) "Open a notmuch-search completion candidate email in Gnus." (message "candidate: %S" candidate) (jao-notmuch-gnus-goto-message (consult-notmuch--candidate-id candidate))) (defun jao-gnus-consult-notmuch () "Run a consult-notmuch query that opens candidates in Gnus." (interactive) (jao-notmuch-gnus--open-candidate (consult-notmuch--search))) (consult-customize jao-gnus-consult-notmuch :preview-key 'any)) ;;; . (provide 'jao-notmuch-gnus) ;;; jao-notmuch-gnus.el ends here