summaryrefslogtreecommitdiffhomepage
path: root/lib/net
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2024-10-29 00:41:30 +0000
committerjao <jao@gnu.org>2024-10-29 00:41:30 +0000
commita7c09173974e4f4a1bb94c2eae4de0b47e5eb966 (patch)
tree534955462b23058d2663c1344b3b8261a27617fe /lib/net
parent6675c7b46425bdd00a07bf3aaaffc8680b1aef42 (diff)
downloadelibs-a7c09173974e4f4a1bb94c2eae4de0b47e5eb966.tar.gz
elibs-a7c09173974e4f4a1bb94c2eae4de0b47e5eb966.tar.bz2
gnus/notmuch interaction recovered
Diffstat (limited to 'lib/net')
-rw-r--r--lib/net/jao-notmuch-gnus.el226
1 files changed, 226 insertions, 0 deletions
diff --git a/lib/net/jao-notmuch-gnus.el b/lib/net/jao-notmuch-gnus.el
new file mode 100644
index 0000000..5eedd97
--- /dev/null
+++ b/lib/net/jao-notmuch-gnus.el
@@ -0,0 +1,226 @@
+;;; jao-notmuch-gnus.el --- notmuch-gnus interoperability -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2022, 2024 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:
+
+;; 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
+
+(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