consult-notmuch.el (13847B)
1 ;;; consult-notmuch.el --- Notmuch search using consult -*- lexical-binding: t; -*- 2 3 ;; Author: Jose A Ortega Ruiz <jao@gnu.org> 4 ;; Maintainer: Jose A Ortega Ruiz 5 ;; Keywords: mail 6 ;; License: GPL-3.0-or-later 7 ;; Version: 0.8.1 8 ;; Package-Requires: ((emacs "26.1") (consult "0.9") (notmuch "0.31")) 9 ;; Homepage: https://codeberg.org/jao/consult-notmuch 10 11 12 ;; Copyright (C) 2021, 2022, 2024 Jose A Ortega Ruiz 13 14 ;; This program is free software; you can redistribute it and/or modify 15 ;; it under the terms of the GNU General Public License as published by 16 ;; the Free Software Foundation, either version 3 of the License, or 17 ;; (at your option) any later version. 18 19 ;; This program is distributed in the hope that it will be useful, 20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 ;; GNU General Public License for more details. 23 24 ;; You should have received a copy of the GNU General Public License 25 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 26 27 ;;; Commentary: 28 29 ;; This package provides two commands using consult to query notmuch 30 ;; emails and present results either as single emails 31 ;; (`consult-notmuch') or full trees (`consult-notmuch-tree'). 32 ;; 33 ;; The package also defines a narrowing source for `consult-buffer', 34 ;; which can be activated with 35 ;; 36 ;; (add-to-list 'consult-buffer-sources 'consult-notmuch-buffer-source) 37 38 ;; This elisp file is automatically generated from its literate 39 ;; counterpart at 40 ;; https://codeberg.org/jao/consult-notmuch/src/branch/main/readme.org 41 42 ;;; Code: 43 44 (require 'consult) 45 (require 'notmuch) 46 47 (defgroup consult-notmuch nil 48 "Options for `consult-notmuch'." 49 :group 'consult) 50 51 (defcustom consult-notmuch-show-single-message t 52 "Show only the matching message or the whole thread in listings." 53 :type 'boolean) 54 55 (defcustom consult-notmuch-result-format 56 '(("date" . "%12s ") 57 ("count" . "%-7s ") 58 ("authors" . "%-20s") 59 ("subject" . " %-54s") 60 ("tags" . " (%s)")) 61 "Format for matching candidates in minibuffer. 62 Supported fields are: date, authors, subject, count and tags." 63 :type '(alist :key-type string :value-type string)) 64 65 (defcustom consult-notmuch-newest-first t 66 "List messages newest first (defaults to oldest first)." 67 :type 'boolean) 68 69 70 (defun consult-notmuch--command (input) 71 "Construct a search command for emails containing INPUT." 72 (let ((sort (if consult-notmuch-newest-first 73 "--sort=newest-first" 74 "--sort=oldest-first"))) 75 (if consult-notmuch-show-single-message 76 `(,notmuch-command "show" "--body=false" ,sort ,input) 77 `(,notmuch-command "search" ,sort ,input)))) 78 79 (defun consult-notmuch--search (&optional initial) 80 "Perform an asynchronous notmuch search via `consult--read'. 81 If given, use INITIAL as the starting point of the query." 82 (setq consult-notmuch--partial-parse nil) 83 (consult--read (consult--async-command 84 #'consult-notmuch--command 85 (consult--async-filter #'identity) 86 (consult--async-map #'consult-notmuch--transformer)) 87 :prompt "Notmuch search: " 88 :require-match t 89 :initial (consult--async-split-initial initial) 90 :history '(:input consult-notmuch-history) 91 :state #'consult-notmuch--preview 92 :lookup #'consult--lookup-member 93 :category 'notmuch-result 94 :sort nil)) 95 96 (defvar consult-notmuch-history nil 97 "History for `consult-notmuch'.") 98 99 (defun consult-notmuch--transformer (str) 100 "Transform STR to notmuch display style." 101 (if consult-notmuch-show-single-message 102 (consult-notmuch--show-transformer str) 103 (consult-notmuch--search-transformer str))) 104 105 (defun consult-notmuch--format-field (spec msg) 106 "Return a string for SPEC given the MSG metadata." 107 (let ((field (car spec))) 108 (cond ((equal field "count") 109 (when-let (cnt (plist-get msg :count)) 110 (format (cdr spec) cnt))) 111 ((equal field "tags") 112 (when (plist-get msg :tags) 113 (notmuch-tree-format-field "tags" (cdr spec) msg))) 114 (t (notmuch-tree-format-field field (cdr spec) msg))))) 115 116 (defun consult-notmuch--format-candidate (msg) 117 "Format the result (MSG) of parsing a notmuch show information unit." 118 (when-let (id (plist-get msg :id)) 119 (let ((result-string)) 120 (dolist (spec consult-notmuch-result-format) 121 (when-let (field (consult-notmuch--format-field spec msg)) 122 (setq result-string (concat result-string field)))) 123 (propertize result-string 'id id 'tags (plist-get msg :tags))))) 124 125 (defun consult-notmuch--candidate-id (candidate) 126 "Recover the thread id for the given CANDIDATE string." 127 (when candidate (get-text-property 0 'id candidate))) 128 129 (defun consult-notmuch--candidate-tags (candidate) 130 "Recover the message tags for the given CANDIDATE string." 131 (when candidate (get-text-property 0 'tags candidate))) 132 133 (defvar consult-notmuch--partial-parse nil 134 "Internal variable for parsing status.") 135 (defvar consult-notmuch--partial-headers nil 136 "Internal variable for parsing status.") 137 (defvar consult-notmuch--info nil 138 "Internal variable for parsing status.") 139 140 (defun consult-notmuch--set (k v) 141 "Set the value V for property K in the message we're currently parsing." 142 (setq consult-notmuch--partial-parse 143 (plist-put consult-notmuch--partial-parse k v))) 144 145 (defun consult-notmuch--show-transformer (str) 146 "Parse output STR of notmuch show, extracting its components." 147 (if (string-prefix-p " message}" str) 148 (prog1 149 (consult-notmuch--format-candidate 150 (consult-notmuch--set :headers consult-notmuch--partial-headers)) 151 (setq consult-notmuch--partial-parse nil 152 consult-notmuch--partial-headers nil 153 consult-notmuch--info nil)) 154 (cond ((string-match " message{ \\(id:[^ ]+\\) .+" str) 155 (consult-notmuch--set :id (match-string 1 str)) 156 (consult-notmuch--set :match t)) 157 ((string-prefix-p " header{" str) 158 (setq consult-notmuch--info t)) 159 ((and str consult-notmuch--info) 160 (when (string-match "\\(.+\\) (\\([^)]+\\)) (\\([^)]*\\))$" str) 161 (consult-notmuch--set :Subject (match-string 1 str)) 162 (consult-notmuch--set :date_relative (match-string 2 str)) 163 (consult-notmuch--set :tags (split-string (match-string 3 str)))) 164 (setq consult-notmuch--info nil)) 165 ((string-match "\\(Subject\\|From\\|To\\|Cc\\|Date\\): \\(.+\\)?" str) 166 (let ((k (intern (format ":%s" (match-string 1 str)))) 167 (v (or (match-string 2 str) ""))) 168 (setq consult-notmuch--partial-headers 169 (plist-put consult-notmuch--partial-headers k v))))) 170 nil)) 171 172 (defun consult-notmuch--search-transformer (str) 173 "Transform STR from notmuch search to notmuch display style." 174 (when (string-match "thread:" str) 175 (let* ((id (car (split-string str "\\ +"))) 176 (date (substring str 24 37)) 177 (mid (substring str 24)) 178 (c0 (string-match "[[]" mid)) 179 (c1 (string-match "[]]" mid)) 180 (count (substring mid c0 (1+ c1))) 181 (auths (string-trim (nth 1 (split-string mid "[];]")))) 182 (subject (string-trim (nth 1 (split-string mid "[;]")))) 183 (headers (list :Subject subject :From auths)) 184 (t0 (string-match "([^)]*)\\s-*$" mid)) 185 (tags (split-string (substring mid (1+ t0) -1))) 186 (msg (list :id id 187 :match t 188 :headers headers 189 :count count 190 :date_relative date 191 :tags tags))) 192 (consult-notmuch--format-candidate msg)))) 193 194 195 (defvar consult-notmuch--buffer-name "*consult-notmuch*" 196 "Name of preview and result buffers.") 197 198 (defun consult-notmuch--show-id (id buffer) 199 "Show message or thread id in the requested buffer" 200 (let ((notmuch-show-only-matching-messages 201 consult-notmuch-show-single-message)) 202 (notmuch-show id nil nil nil buffer))) 203 204 (defun consult-notmuch--preview (action candidate) 205 "Preview CANDIDATE when ACTION is 'preview." 206 (cond ((eq action 'preview) 207 (when-let ((id (consult-notmuch--candidate-id candidate))) 208 (when (get-buffer consult-notmuch--buffer-name) 209 (kill-buffer consult-notmuch--buffer-name)) 210 (consult-notmuch--show-id id consult-notmuch--buffer-name))) 211 ((eq action 'exit) 212 (when (get-buffer consult-notmuch--buffer-name) 213 (kill-buffer consult-notmuch--buffer-name))))) 214 215 216 (defun consult-notmuch--show (candidate) 217 "Open resulting CANDIDATE in ‘notmuch-show’ view." 218 (when-let ((id (consult-notmuch--candidate-id candidate))) 219 (let* ((subject (car (last (split-string candidate "\t")))) 220 (title (concat consult-notmuch--buffer-name " " subject))) 221 (consult-notmuch--show-id id title)))) 222 223 224 (defun consult-notmuch--tree (candidate) 225 "Open resulting CANDIDATE in ‘notmuch-tree’." 226 (when-let ((thread-id (consult-notmuch--candidate-id candidate))) 227 (notmuch-tree thread-id nil nil))) 228 229 230 ;; Embark Integration: 231 (with-eval-after-load 'embark 232 (defvar consult-notmuch-map 233 (let ((map (make-sparse-keymap))) 234 (define-key map (kbd "+") 'consult-notmuch-tag) 235 (define-key map (kbd "-") 'consult-notmuch-tag) 236 map) 237 "Keymap for actions on Notmuch entries.") 238 239 (set-keymap-parent consult-notmuch-map embark-general-map) 240 (add-to-list 'embark-keymap-alist '(notmuch-result . consult-notmuch-map)) 241 242 (defun consult-notmuch--address-to-multi-select (address) 243 "Select more email addresses, in addition to the current selection" 244 (consult-notmuch-address t address)) 245 246 (defvar consult-notmuch-address-map 247 (let ((map (make-sparse-keymap))) 248 (define-key map (kbd "c") #'consult-notmuch-address-compose) 249 (define-key map (kbd "m") #'consult-notmuch--address-to-multi-select) 250 map)) 251 252 (set-keymap-parent consult-notmuch-address-map embark-general-map) 253 (add-to-list 'embark-keymap-alist 254 '(notmuch-address . consult-notmuch-address-map)) 255 256 (defun consult-notmuch-tag (msg) 257 (when-let* ((id (consult-notmuch--candidate-id msg)) 258 (tags (consult-notmuch--candidate-tags msg)) 259 (tag-changes (notmuch-read-tag-changes tags "Tags: " "+"))) 260 (notmuch-tag (concat "(" id ")") tag-changes))) 261 262 (defvar consult-notmuch-export-function #'notmuch-search 263 "Function used to ask notmuch to display a list of found ids. 264 Typical options are notmuch-search and notmuch-tree.") 265 266 (defun consult-notmuch-export (msgs) 267 "Create a notmuch search buffer listing messages." 268 (funcall consult-notmuch-export-function 269 (concat "(" (mapconcat #'consult-notmuch--candidate-id msgs " ") ")"))) 270 (add-to-list 'embark-exporters-alist 271 '(notmuch-result . consult-notmuch-export))) 272 273 ;;;###autoload 274 (defun consult-notmuch (&optional initial) 275 "Search for your email in notmuch, showing single messages. 276 If given, use INITIAL as the starting point of the query." 277 (interactive) 278 (consult-notmuch--show (consult-notmuch--search initial))) 279 280 ;;;###autoload 281 (defun consult-notmuch-tree (&optional initial) 282 "Search for your email in notmuch, showing full candidate tree. 283 If given, use INITIAL as the starting point of the query." 284 (interactive) 285 (consult-notmuch--tree (consult-notmuch--search initial))) 286 287 (defun consult-notmuch--address-command (input) 288 "Spec for an async command querying a notmuch address with INPUT." 289 `(,notmuch-command "address" "--format=text" ,input)) 290 291 (defun consult-notmuch-address-compose (address) 292 "Compose an email to a given ADDRESS." 293 (let ((other-headers (and notmuch-always-prompt-for-sender 294 `((From . ,(notmuch-mua-prompt-for-sender)))))) 295 (notmuch-mua-mail address 296 nil 297 other-headers 298 nil 299 (notmuch-mua-get-switch-function)))) 300 301 (defun consult-notmuch--address-prompt () 302 (consult--read (consult--async-command #'consult-notmuch--address-command) 303 :prompt "Notmuch addresses: " 304 :sort nil 305 :category 'notmuch-address)) 306 307 ;;;###autoload 308 (defun consult-notmuch-address (&optional multi-select-p initial-addr) 309 "Search the notmuch db for an email address and compose mail to it. 310 With a prefix argument, prompt multiple times until there 311 is an empty input." 312 (interactive "P") 313 (if multi-select-p 314 (cl-loop for addr = (consult-notmuch--address-prompt) 315 until (eql (length addr) 0) 316 collect addr into addrs 317 finally (consult-notmuch-address-compose 318 (mapconcat #'identity 319 (if initial-addr 320 (cons initial-addr addrs) 321 addrs) 322 ", "))) 323 (consult-notmuch-address-compose (consult-notmuch--address-prompt)))) 324 325 326 (defun consult-notmuch--interesting-buffers () 327 "Return a list of names of buffers with interesting notmuch data." 328 (consult--buffer-query 329 :as (lambda (buf) 330 (when (notmuch-interesting-buffer buf) 331 (buffer-name buf))))) 332 333 ;;;###autoload 334 (defvar consult-notmuch-buffer-source 335 '(:name "Notmuch Buffer" 336 :narrow (?n . "Notmuch") 337 :hidden t 338 :category buffer 339 :face consult-buffer 340 :history buffer-name-history 341 :state consult--buffer-state 342 :items consult-notmuch--interesting-buffers) 343 "Notmuch buffer candidate source for `consult-buffer'.") 344 345 (provide 'consult-notmuch) 346 ;;; consult-notmuch.el ends here