1 ;;; gnorb-gnus.el --- The gnus-centric fuctions of gnorb
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
28 (require 'gnorb-utils)
30 (declare-function org-gnus-article-link "org-gnus"
31 (group newsgroups message-id x-no-archive))
32 (declare-function org-gnus-follow-link "org-gnus"
35 (defgroup gnorb-gnus nil
36 "The Gnus bits of Gnorb."
41 (defcustom gnorb-gnus-mail-search-backends
42 '((notmuch (lambda (terms)
45 (replace-regexp-in-string "\\." "\\\\." m))
48 (mairix (lambda (terms)
52 (namazu (lambda (terms)
56 "Various backends for mail search.
58 An alist of backends, where each element consists of three parts:
59 the symbol name of the backend, a lambda form which receives a
60 list of email addresses and returns a properly-formatted search
61 string, and the symbol name of the function used to initiate the
66 (defcustom gnorb-gnus-mail-search-backend nil
67 "Mail search backend currently in use. One of the three symbols
68 notmuch, namazu, or mairix."
72 (defcustom gnorb-gnus-capture-always-attach nil
73 "Always prompt about attaching attachments when capturing from
74 a Gnus message, even if the template being used hasn't
75 specified the :gnus-attachments key.
77 Basically behave as if all attachments have \":gnus-attachments t\"."
81 (defcustom gnorb-gnus-new-todo-capture-key nil
82 "Key for the capture template to use when creating a new TODO
83 from an outgoing message."
87 (defcustom gnorb-gnus-hint-relevant-article t
88 "When opening a gnus message, should gnorb let you know if the
89 message is relevant to an existing TODO?"
93 (defcustom gnorb-gnus-summary-mark-format-letter "g"
94 "Format letter to be used as part of your
95 `gnus-summary-line-format', to indicate in the *Summary* buffer
96 which articles might be relevant to TODOs. Since this is a user
97 format code, it should be prefixed with %u, eg %ug. It will
98 result in the insertion of the value of
99 `gnorb-gnus-summary-mark', for relevant messages, or
104 (defcustom gnorb-gnus-summary-mark "ยก"
105 "Default mark to insert in the summary format line of articles
106 that are likely relevant to existing TODO headings."
110 (defcustom gnorb-gnus-trigger-refile-targets
111 '((org-agenda-files :maxlevel . 4))
112 "A value to use as an equivalent of `org-refile-targets' (which
113 see) when offering trigger targets for
114 `gnorb-gnus-incoming-do-todo'."
118 (defcustom gnorb-gnus-sent-groups nil
119 "A list of strings indicating sent mail groups.
121 In some cases, Gnorb can't detect where your sent messages are
122 stored (ie if you're using IMAP sent mail folders instead of
123 local archiving. If you want Gnorb to be able to find sent
124 messages, this option can help it do that. It should be set to a
125 list of strings, which are assumed to be fully qualified
126 server+group combinations, ie \"nnimap+Server:[Gmail]/Sent
127 Mail\", or something similar. This only has to be done once for
132 (defvar gnorb-gnus-capture-attachments nil
133 "Holding place for attachment names during the capture
136 ;;; What follows is a very careful copy-pasta of bits and pieces from
137 ;;; mm-decode.el and gnus-art.el. Voodoo was involved.
140 (defun gnorb-gnus-article-org-attach (n)
141 "Save MIME part N, which is the numerical prefix, of the
142 article under point as an attachment to the specified org
145 (gnus-article-part-wrapper n 'gnorb-gnus-attach-part))
148 (defun gnorb-gnus-mime-org-attach ()
149 "Save the MIME part under point as an attachment to the
150 specified org heading."
152 (gnus-article-check-buffer)
153 (let ((data (get-text-property (point) 'gnus-data)))
155 (gnorb-gnus-attach-part data))))
157 (defun gnorb-gnus-attach-part (handle &optional org-heading)
158 "Attach HANDLE to an existing org heading."
159 (let* ((filename (gnorb-gnus-save-part handle))
160 (org-refile-targets gnorb-gnus-trigger-refile-targets)
161 (headers (gnus-data-header
163 (gnus-summary-article-number))))
164 (tracked-headings (gnorb-find-tracked-headings headers))
166 (gnorb-choose-trigger-heading tracked-headings)))
167 (require 'org-attach)
168 (save-window-excursion
169 (org-id-goto target-heading)
170 (org-attach-attach filename nil 'mv))))
172 (defun gnorb-gnus-save-part (handle)
173 (let ((filename (or (mail-content-type-get
174 (mm-handle-disposition handle) 'filename)
175 (mail-content-type-get
176 (mm-handle-type handle) 'name))))
178 (gnus-map-function mm-file-name-rewrite-functions
179 (file-name-nondirectory filename)))
180 (setq filename (expand-file-name filename gnorb-tmp-dir))
181 (mm-save-part-to-file handle filename)
184 (defun gnorb-gnus-collect-all-attachments (&optional capture-p store)
185 "Collect all the attachments from the message under point, and
186 save them into `gnorb-tmp-dir'."
187 (save-window-excursion
189 (set-buffer (org-capture-get :original-buffer)))
190 (unless (memq major-mode '(gnus-summary-mode gnus-article-mode))
191 (error "Only works in Gnus summary or article buffers"))
192 (let ((article (gnus-summary-article-number))
194 (when (or (null gnus-current-article)
195 (null gnus-article-current)
196 (/= article (cdr gnus-article-current))
197 (not (equal (car gnus-article-current) gnus-newsgroup-name)))
198 (gnus-summary-display-article article))
199 (gnus-eval-in-buffer-window gnus-article-buffer
200 (setq mime-handles (cl-remove-if-not
202 (let ((disp (mm-handle-disposition (cdr h))))
203 (and (member (car disp)
204 '("inline" "attachment"))
205 (mail-content-type-get disp 'filename))))
206 gnus-article-mime-handle-alist)))
208 (dolist (h mime-handles)
210 (gnorb-gnus-save-part (cdr h))))
211 (when (or capture-p store)
212 (push filename gnorb-gnus-capture-attachments))))))))
214 ;;; Make the above work in the capture process
216 (defun gnorb-gnus-capture-attach ()
217 (when (and (or gnorb-gnus-capture-always-attach
218 (org-capture-get :gnus-attachments))
220 (org-capture-get :original-buffer)
221 (memq major-mode '(gnus-summary-mode gnus-article-mode))))
222 (require 'org-attach)
223 (setq gnorb-gnus-capture-attachments nil)
224 (gnorb-gnus-collect-all-attachments t)
227 (format "Attach %s to capture heading? "
228 (file-name-nondirectory a)))
229 (lambda (a) (org-attach-attach a nil 'mv))
230 gnorb-gnus-capture-attachments
231 '("file" "files" "attach"))
232 (setq gnorb-gnus-capture-attachments nil)))
234 (add-hook 'org-capture-mode-hook 'gnorb-gnus-capture-attach)
236 (defun gnorb-gnus-capture-abort-cleanup ()
237 (when (and org-note-abort
238 (org-capture-get :gnus-attachments))
239 ;; FIXME: Yuck: setting `abort-note' will fail as soon as org-capture.el is
240 ;; compiled with lexical-binding!
242 (progn (org-attach-delete-all)
243 (setq abort-note 'clean)
244 ;; remove any gnorb-mail-header values here
247 (setq abort-note 'dirty)))))
249 (add-hook 'org-capture-prepare-finalize-hook
250 'gnorb-gnus-capture-abort-cleanup)
252 ;;; Storing, removing, and acting on Org headers in messages.
254 (defvar gnorb-gnus-message-info nil
255 "Place to store the To, Subject, Date, and Message-ID headers
256 of the currently-sending or last-sent message.")
258 (defun gnorb-gnus-check-outgoing-headers ()
259 "Save the value of the `gnorb-mail-header' for the current
260 message; multiple header values returned as a string. Also save
261 information about the outgoing message into
262 `gnorb-gnus-message-info'."
264 (message-narrow-to-headers)
265 (setq gnorb-gnus-message-info nil)
266 (let* ((org-ids (mail-fetch-field gnorb-mail-header nil nil t))
267 (msg-id (mail-fetch-field "Message-ID"))
268 (refs (mail-fetch-field "References"))
269 (in-reply-to (mail-fetch-field "In-Reply-To"))
270 (to (if (message-news-p)
271 (mail-fetch-field "Newsgroups")
272 (mail-fetch-field "To")))
273 (from (mail-fetch-field "From"))
274 (subject (mail-fetch-field "Subject"))
275 (date (mail-fetch-field "Date"))
276 ;; If we can get a link, that's awesome.
277 (gcc (mail-fetch-field "Gcc"))
279 (org-store-link nil))
281 (group (ignore-errors (car (split-string link "#")))))
282 ;; If we can't make a real link, then save some information so
285 (setq refs (concat refs " " in-reply-to)))
287 (setq refs (gnus-extract-references refs)))
288 (setq gnorb-gnus-message-info
289 `(:subject ,subject :msg-id ,msg-id
291 :link ,link :date ,date :refs ,refs
296 (setq gnorb-message-org-ids org-ids)
297 ;; `gnorb-org-setup-message' may have put this here, but
298 ;; if we're working from a draft, or triggering this from
299 ;; a reply, it might not be there yet.
300 (add-to-list 'message-exit-actions
301 'gnorb-org-restore-after-send t))
302 (setq gnorb-message-org-ids nil)))))
304 (add-hook 'message-header-hook 'gnorb-gnus-check-outgoing-headers)
307 (defun gnorb-gnus-outgoing-do-todo (&optional arg)
308 "Use this command to use the message currently being composed
309 as an email todo action.
311 If it's a new message, or a reply to a message that isn't
312 referenced by any TODOs, a new TODO will be created.
314 If it references an existing TODO, you'll be prompted to trigger
315 a state-change or a note on that TODO after the message is sent.
317 You can call it with a prefix arg to force choosing an Org
318 subtree to associate with.
320 If you've already called this command, but realize you made a
321 mistake, you can call this command with a double prefix to reset
324 If a new todo is made, it needs a capture template: set
325 `gnorb-gnus-new-todo-capture-key' to the string key for the
326 appropriate capture template. If you're using a gnus-based
327 archive method (ie you have `gnus-message-archive-group' set to
328 something, and your outgoing messages have a \"Fcc\" header),
329 then a real link will be made to the outgoing message, and all
330 the gnus-type escapes will be available (see the Info
331 manual (org) Template expansion section). If you don't, then the
332 %:subject, %:to, %:toname, %:toaddress, and %:date escapes for
333 the outgoing message will still be available -- nothing else will
336 (let ((org-refile-targets gnorb-gnus-trigger-refile-targets)
337 (compose-marker (make-marker))
338 header-ids ref-ids rel-headings
339 gnorb-window-conf in-reply-to)
340 (when (equal arg '(4))
342 (org-refile-get-location "Trigger action on" nil t))
344 (list (list (save-window-excursion
345 (find-file (nth 1 rel-headings))
346 (goto-char (nth 3 rel-headings))
347 (org-id-get-create))))))
348 (if (not (eq major-mode 'message-mode))
349 ;; The message is already sent, so we're relying on whatever was
350 ;; stored into `gnorb-gnus-message-info'.
351 (if (equal arg '(16))
352 (user-error "A double prefix is only useful with an
356 (push (car rel-headings) gnorb-message-org-ids)
357 (gnorb-org-restore-after-send))
358 (setq ref-ids (plist-get gnorb-gnus-message-info :refs))
360 ;; the message might be relevant to some TODO
361 ;; heading(s). But if there had been org-id
362 ;; headers, they would already have been
363 ;; handled when the message was sent.
365 (setq rel-headings (gnorb-find-visit-candidates ref-ids))
366 (if (not rel-headings)
367 (gnorb-gnus-outgoing-make-todo-1)
368 (dolist (h rel-headings)
369 (push h gnorb-message-org-ids))
370 (gnorb-org-restore-after-send)))
371 ;; not relevant, just make a new TODO
372 (gnorb-gnus-outgoing-make-todo-1))))
373 ;; We are still in the message composition buffer, so let's see
376 (if (equal arg '(16))
377 ;; Double prefix arg means delete the association we already
382 (setq message-exit-actions
383 (remove 'gnorb-org-restore-after-send
384 (remove 'gnorb-gnus-outgoing-make-todo-1
385 message-exit-actions)))
386 (message-narrow-to-headers-or-head)
387 (message-remove-header
389 (message "Message associations have been reset")))
390 ;; Save-excursion won't work, because point will move if we
392 (move-marker compose-marker (point))
395 (message-narrow-to-headers-or-head)
396 (setq header-ids (mail-fetch-field gnorb-mail-header nil nil t))
397 ;; With a prefix arg we do not check references, because the
398 ;; whole point is to add new references. We still want to know
399 ;; what org id headers are present, though, so we don't add
401 (setq ref-ids (unless arg (mail-fetch-field "References" t)))
402 (setq in-reply-to (unless arg (mail-fetch-field "In-Reply-to" t)))
404 (setq ref-ids (concat ref-ids " " in-reply-to)))
406 ;; if the References header points to any message ids that are
407 ;; tracked by TODO headings...
408 (setq rel-headings (gnorb-find-visit-candidates ref-ids)))
410 (goto-char (point-min))
411 (dolist (h (delete-dups rel-headings))
412 ;; then get the org-ids of those headings, and insert
413 ;; them into this message as headers. If the id was
414 ;; already present in a header, don't add it again.
415 (unless (member h header-ids)
416 (goto-char (point-at-bol))
418 (message-insert-header
419 (intern gnorb-mail-header)
421 ;; tell the rest of the function that this is a relevant
423 (push h header-ids)))))
424 (goto-char compose-marker)
426 'message-exit-actions
428 'gnorb-org-restore-after-send
429 'gnorb-gnus-outgoing-make-todo-1)
433 "Message will trigger TODO state-changes after sending"
434 "A TODO will be made from this message after it's sent"))))))
436 (defvar org-capture-link-is-already-stored)
438 (defun gnorb-gnus-outgoing-make-todo-1 ()
439 (unless gnorb-gnus-new-todo-capture-key
440 (error "No capture template key set, customize gnorb-gnus-new-todo-capture-key"))
441 (let* ((link (plist-get gnorb-gnus-message-info :link))
442 (group (plist-get gnorb-gnus-message-info :group))
443 (date (plist-get gnorb-gnus-message-info :date))
447 (org-time-stamp-format t)
448 (date-to-time date)))))
449 (date-ts-ia (and date
452 (org-time-stamp-format t t)
453 (date-to-time date)))))
454 (msg-id (plist-get gnorb-gnus-message-info :msg-id))
455 (sender (plist-get gnorb-gnus-message-info :from))
456 (subject (plist-get gnorb-gnus-message-info :subject))
457 ;; Convince Org we already have a link stored, even if we
459 (org-capture-link-is-already-stored t))
461 ;; Even if you make a link to not-yet-sent messages, even if
462 ;; you've saved the draft and it has a Date header, that
463 ;; header isn't saved into the link plist. So fake that, too.
466 :date-timestamp date-ts
467 :date-timestamp-inactive date-ts-ia
469 (org-store-link-props
470 :subject (plist-get gnorb-gnus-message-info :subject)
471 :to (plist-get gnorb-gnus-message-info :to)
473 :date-timestamp date-ts
474 :date-timestamp-inactive date-ts-ia
477 (org-capture nil gnorb-gnus-new-todo-capture-key)
479 (org-entry-put (point) gnorb-org-msg-id-key msg-id)
480 (gnorb-registry-make-entry msg-id sender subject (org-id-get-create) group))))
482 ;;; If an incoming message should trigger state-change for a Org todo,
483 ;;; call this function on it.
486 (defun gnorb-gnus-incoming-do-todo (arg &optional id)
487 "Call this function from a received gnus message to store a
488 link to the message, prompt for a related Org heading, visit the
489 heading, and either add a note or trigger a TODO state change.
490 Set `gnorb-trigger-todo-default' to 'note or 'todo (you can
491 get the non-default behavior by calling this function with a
492 prefix argument), or to 'prompt to always be prompted.
494 In some cases, Gnorb can guess for you which Org heading you
495 probably want to trigger, which can save some time. It does this
496 by looking in the References header, and seeing if any of the IDs
497 there match the value of the `gnorb-org-msg-id-key' property for
498 any headings. In order for this to work, you will have to have
499 loaded org-id, and have the variable `org-id-track-globally' set
500 to t (it is, by default)."
502 (when (not (memq major-mode '(gnus-summary-mode gnus-article-mode)))
503 (user-error "Only works in gnus summary or article mode"))
504 ;; We should only store a link if it's not already at the head of
505 ;; `org-stored-links'. There's some duplicate storage, at
506 ;; present. Take a look at calling it non-interactively.
507 (setq gnorb-window-conf (current-window-configuration))
508 (move-marker gnorb-return-marker (point))
509 (setq gnorb-gnus-message-info nil)
510 (let* ((headers (gnus-data-header
512 (gnus-summary-article-number))))
513 (msg-id (mail-header-id headers))
514 (from (mail-header-from headers))
515 (subject (mail-header-subject headers))
516 (date (mail-header-date headers))
517 (to (cdr (assoc 'To (mail-header-extra headers))))
518 (group gnus-newsgroup-name)
519 (link (call-interactively 'org-store-link))
520 (org-refile-targets gnorb-gnus-trigger-refile-targets)
521 (ref-msg-ids (concat (mail-header-references headers) " "
524 (when (and (null id) ref-msg-ids)
525 ;; Specifically ask for zombies, so the user has chance to
527 (gnorb-find-tracked-headings headers t)))
529 (setq gnorb-gnus-message-info
530 `(:subject ,subject :msg-id ,msg-id
532 :link ,link :date ,date :refs ,ref-msg-ids
534 (gnorb-gnus-collect-all-attachments nil t)
535 ;; Delete other windows, users can restore with
536 ;; `gnorb-restore-layout'.
537 (delete-other-windows)
539 (gnorb-trigger-todo-action arg id)
540 ;; Flush out zombies (dead associations).
541 (setq related-headings
544 (when (null (org-id-find-id-file h))
547 "ID %s no longer exists, disassociate message?"
549 (gnorb-delete-association msg-id h))))
552 (dolist (h related-headings nil)
554 (format "Trigger action on %s"
555 (gnorb-pretty-outline h)))
556 (throw 'target (setq targ h)))))
557 (gnorb-trigger-todo-action arg targ)
558 (setq targ (org-refile-get-location
559 "Trigger heading" nil t))
560 (find-file (nth 1 targ))
561 (goto-char (nth 3 targ))
562 (gnorb-trigger-todo-action arg)))))
565 (defun gnorb-gnus-search-messages (str &optional ret)
566 "Initiate a search for gnus message links in an org subtree.
567 The arg STR can be one of two things: an Org heading id value
568 \(IDs should be prefixed with \"id+\"\), in which case links will
569 be collected from that heading, or a string corresponding to an
570 Org tags search, in which case links will be collected from all
573 In either case, once a collection of links have been made, they
574 will all be displayed in an ephemeral group on the \"nngnorb\"
575 server. There must be an active \"nngnorb\" server for this to
580 (or (gnus-method-to-server '(nngnorb))
582 "Please add a \"nngnorb\" backend to your gnus installation."))))
583 (when (version= "5.13" gnus-version-number)
584 (with-no-warnings ; All these variables are available.
585 (setq nnir-current-query nil
586 nnir-current-server nil
587 nnir-current-group-marked nil
589 (gnus-group-read-ephemeral-group
590 ;; in 24.4, the group name is mostly decorative. in 24.3, the
591 ;; query itself is read from there. It should look like (concat
592 ;; "nnir:" (prin1-to-string '((query str))))
593 (if (version= "5.13" gnus-version-number)
594 (concat "nnir:" (prin1-to-string `((query ,str))))
595 (concat "gnorb-" str))
596 (if (version= "5.13" gnus-version-number)
597 (list 'nnir nnir-address)
602 ;; the following seems to simply be ignored under gnus 5.13
603 (list (cons 'nnir-specs (list (cons 'nnir-query-spec `((query . ,str)))
604 (cons 'nnir-group-spec `((,nnir-address nil)))))
605 (cons 'nnir-artlist nil)))
606 (gnorb-summary-minor-mode)))
608 ;;; Automatic noticing of relevant messages
610 ;; likely hooks for the summary buffer include:
611 ;; `gnus-parse-headers-hook'
613 ;; BBDB puts its notice stuff in the `gnus-article-prepare-hook',
614 ;; which seems as good a spot as any.
616 (defun gnorb-gnus-hint-relevant-message ()
617 "When opening an article buffer, check the message to see if it
618 is relevant to any existing TODO headings. If so, flash a message
619 to that effect. This function is added to the
620 `gnus-article-prepare-hook'. It will only do anything if the
621 option `gnorb-gnus-hint-relevant-article' is non-nil."
622 (when (and gnorb-gnus-hint-relevant-article
623 (not (memq (car (gnus-find-method-for-group
624 gnus-newsgroup-name))
629 (gnus-summary-article-number))))
631 (gnus-registry-get-id-key
632 (gnus-fetch-original-field "message-id") 'gnorb-ids))
633 (tracked-headings (gnorb-find-tracked-headings headers))
635 (where-is-internal 'gnorb-gnus-incoming-do-todo
639 (message "Message is associated with %s"
640 (gnorb-pretty-outline (car assoc-heading) t)))
642 (message "Possible relevant todo %s, trigger with %s"
643 (gnorb-pretty-outline (car tracked-headings) t)
645 (key-description key)
646 "M-x gnorb-gnus-incoming-do-todo")))
649 (add-hook 'gnus-article-prepare-hook 'gnorb-gnus-hint-relevant-message)
651 (defun gnorb-gnus-insert-format-letter-maybe (header)
652 (if (not (memq (car (gnus-find-method-for-group
653 gnus-newsgroup-name))
655 (if (gnorb-find-tracked-headings header)
656 gnorb-gnus-summary-mark
660 (fset (intern (concat "gnus-user-format-function-"
661 gnorb-gnus-summary-mark-format-letter))
663 (gnorb-gnus-insert-format-letter-maybe header)))
666 (defun gnorb-gnus-view ()
667 "Display the first relevant TODO heading for the message under point"
669 (let* ((headers (gnus-data-header
671 (gnus-summary-article-number))))
673 (gnorb-find-tracked-headings headers)))
674 (when tracked-headings
675 (setq gnorb-window-conf (current-window-configuration))
676 (move-marker gnorb-return-marker (point))
677 (delete-other-windows)
678 (org-id-goto (car tracked-headings)))))
680 (provide 'gnorb-gnus)
681 ;;; gnorb-gnus.el ends here