code.delx.au - gnu-emacs-elpa/blob - packages/gnorb/gnorb-gnus.el

   1 ;;; gnorb-gnus.el --- The gnus-centric fuctions of gnorb
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
   6 ;; Keywords:
   7
   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.
  12
  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.
  17
  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/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (require 'gnus)
  28 (require 'gnorb-utils)
  29
  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"
  33                   (group article))
  34
  35 (defgroup gnorb-gnus nil
  36   "The Gnus bits of Gnorb."
  37   :tag "Gnorb Gnus"
  38   :group 'gnorb)
  39
  40
  41 (defcustom gnorb-gnus-mail-search-backends
  42   '((notmuch (lambda (terms)
  43                (mapconcat
  44                 (lambda (m)
  45                   (replace-regexp-in-string "\\." "\\\\." m))
  46                 terms " OR "))
  47              notmuch-search)
  48     (mairix (lambda (terms)
  49               (mapconcat 'identity
  50                          terms ","))
  51             mairix-search)
  52     (namazu (lambda (terms)
  53               (mapconcat 'identity
  54                          terms " or "))
  55             namazu-search))
  56   "Various backends for mail search.
  57
  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
  62 search."
  63   :group 'gnorb-gnus
  64   :type 'list)
  65
  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."
  69   :group 'gnorb-gnus
  70   :type 'symbol)
  71
  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.
  76
  77 Basically behave as if all attachments have \":gnus-attachments t\"."
  78   :group 'gnorb-gnus
  79   :type 'boolean)
  80
  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."
  84   :group 'gnorb-gnus
  85   :type 'string)
  86
  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?"
  90   :group 'gnorb-gnus
  91   :type 'boolean)
  92
  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
 100   else a space."
 101   :group 'gnorb-gnus
 102   :type 'string)
 103
 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."
 107   :group 'gnorb-gnus
 108   :type 'string)
 109
 110 (defcustom gnorb-gnus-summary-tracked-mark "&"
 111   "Default mark to insert in the summary format line of articles
 112   that are already tracked by TODO headings."
 113   :group 'gnorb-gnus
 114   :type 'string)
 115
 116 (defcustom gnorb-gnus-trigger-refile-targets
 117   '((org-agenda-files :maxlevel . 4))
 118   "A value to use as an equivalent of `org-refile-targets' (which
 119   see) when offering trigger targets for
 120   `gnorb-gnus-incoming-do-todo'."
 121   :group 'gnorb-gnus
 122   :type 'list)
 123
 124 (defcustom gnorb-gnus-sent-groups nil
 125   "A list of strings indicating sent mail groups.
 126
 127 In some cases, Gnorb can't detect where your sent messages are
 128 stored (ie if you're using IMAP sent mail folders instead of
 129 local archiving. If you want Gnorb to be able to find sent
 130 messages, this option can help it do that. It should be set to a
 131 list of strings, which are assumed to be fully qualified
 132 server+group combinations, ie \"nnimap+Server:[Gmail]/Sent
 133 Mail\", or something similar. This only has to be done once for
 134 each message."
 135   :group 'gnorb-gnus
 136   :type 'list)
 137
 138 (defvar gnorb-gnus-capture-attachments nil
 139   "Holding place for attachment names during the capture
 140   process.")
 141
 142 ;;; What follows is a very careful copy-pasta of bits and pieces from
 143 ;;; mm-decode.el and gnus-art.el. Voodoo was involved.
 144
 145 ;;;###autoload
 146 (defun gnorb-gnus-article-org-attach (n)
 147   "Save MIME part N, which is the numerical prefix, of the
 148   article under point as an attachment to the specified org
 149   heading."
 150   (interactive "P")
 151   (gnus-article-part-wrapper n 'gnorb-gnus-attach-part))
 152
 153 ;;;###autoload
 154 (defun gnorb-gnus-mime-org-attach ()
 155   "Save the MIME part under point as an attachment to the
 156   specified org heading."
 157   (interactive)
 158   (gnus-article-check-buffer)
 159   (let ((data (get-text-property (point) 'gnus-data)))
 160     (when data
 161       (gnorb-gnus-attach-part data))))
 162
 163 (defun gnorb-gnus-attach-part (handle &optional org-heading)
 164   "Attach HANDLE to an existing org heading."
 165   (let* ((filename (gnorb-gnus-save-part handle))
 166          (org-refile-targets gnorb-gnus-trigger-refile-targets)
 167          (headers (gnus-data-header
 168                    (gnus-data-find
 169                     (gnus-summary-article-number))))
 170          (tracked-headings (gnorb-find-tracked-headings headers))
 171          (target-heading
 172           (gnorb-choose-trigger-heading tracked-headings)))
 173     (require 'org-attach)
 174     (save-window-excursion
 175       (org-id-goto target-heading)
 176       (org-attach-attach filename nil 'mv))))
 177
 178 (defun gnorb-gnus-save-part (handle)
 179   (let ((filename (or (mail-content-type-get
 180                        (mm-handle-disposition handle) 'filename)
 181                       (mail-content-type-get
 182                        (mm-handle-type handle) 'name))))
 183     (setq filename
 184           (gnus-map-function mm-file-name-rewrite-functions
 185                              (file-name-nondirectory filename)))
 186     (setq filename (expand-file-name filename gnorb-tmp-dir))
 187     (mm-save-part-to-file handle filename)
 188     filename))
 189
 190 (defun gnorb-gnus-collect-all-attachments (&optional capture-p store)
 191   "Collect all the attachments from the message under point, and
 192 save them into `gnorb-tmp-dir'."
 193   (save-window-excursion
 194     (when capture-p
 195       (set-buffer (org-capture-get :original-buffer)))
 196     (unless (memq major-mode '(gnus-summary-mode gnus-article-mode))
 197       (error "Only works in Gnus summary or article buffers"))
 198     (let ((article (gnus-summary-article-number))
 199           mime-handles)
 200       (when (or (null gnus-current-article)
 201                 (null gnus-article-current)
 202                 (/= article (cdr gnus-article-current))
 203                 (not (equal (car gnus-article-current) gnus-newsgroup-name)))
 204         (gnus-summary-display-article article))
 205       (gnus-eval-in-buffer-window gnus-article-buffer
 206         (setq mime-handles (cl-remove-if-not
 207                             (lambda (h)
 208                               (let ((disp (mm-handle-disposition (cdr h))))
 209                                 (and (member (car disp)
 210                                              '("inline" "attachment"))
 211                                      (mail-content-type-get disp 'filename))))
 212                             gnus-article-mime-handle-alist)))
 213       (when mime-handles
 214         (dolist (h mime-handles)
 215           (let ((filename
 216                  (gnorb-gnus-save-part (cdr h))))
 217             (when (or capture-p store)
 218               (push filename gnorb-gnus-capture-attachments))))))))
 219
 220 ;;; Make the above work in the capture process
 221
 222 (defun gnorb-gnus-capture-attach ()
 223   (when (and (or gnorb-gnus-capture-always-attach
 224                  (org-capture-get :gnus-attachments))
 225              (with-current-buffer
 226                  (org-capture-get :original-buffer)
 227                (memq major-mode '(gnus-summary-mode gnus-article-mode))))
 228     (require 'org-attach)
 229     (setq gnorb-gnus-capture-attachments nil)
 230     (gnorb-gnus-collect-all-attachments t)
 231     (map-y-or-n-p
 232      (lambda (a)
 233        (format "Attach %s to capture heading? "
 234                (file-name-nondirectory a)))
 235      (lambda (a) (org-attach-attach a nil 'mv))
 236      gnorb-gnus-capture-attachments
 237      '("file" "files" "attach"))
 238     (setq gnorb-gnus-capture-attachments nil)))
 239
 240 (add-hook 'org-capture-mode-hook 'gnorb-gnus-capture-attach)
 241
 242 (defvar org-note-abort)
 243
 244 (defun gnorb-gnus-capture-abort-cleanup ()
 245   (with-no-warnings ; For `org-note-abort'
 246     (when (and org-note-abort
 247                (or gnorb-gnus-capture-always-attach
 248                    (org-capture-get :gnus-attachments)))
 249      (condition-case error
 250          (progn (org-attach-delete-all)
 251                 (setq abort-note 'clean)
 252                 ;; remove any gnorb-mail-header values here
 253                 )
 254        (error
 255         (setq abort-note 'dirty))))))
 256
 257 (add-hook 'org-capture-prepare-finalize-hook
 258           'gnorb-gnus-capture-abort-cleanup)
 259
 260 ;;; Storing, removing, and acting on Org headers in messages.
 261
 262 (defvar gnorb-gnus-message-info nil
 263   "Place to store the To, Subject, Date, and Message-ID headers
 264   of the currently-sending or last-sent message.")
 265
 266 (defun gnorb-gnus-check-outgoing-headers ()
 267   "Save the value of the `gnorb-mail-header' for the current
 268 message; multiple header values returned as a string. Also save
 269 information about the outgoing message into
 270 `gnorb-gnus-message-info'."
 271   (save-restriction
 272     (message-narrow-to-headers)
 273     (setq gnorb-gnus-message-info nil)
 274     (let* ((org-ids (mail-fetch-field gnorb-mail-header nil nil t))
 275            (msg-id (mail-fetch-field "Message-ID"))
 276            (refs (mail-fetch-field "References"))
 277            (in-reply-to (mail-fetch-field "In-Reply-To"))
 278            (to (if (message-news-p)
 279                    (mail-fetch-field "Newsgroups")
 280                  (mail-fetch-field "To")))
 281            (from (mail-fetch-field "From"))
 282            (subject (mail-fetch-field "Subject"))
 283            (date (mail-fetch-field "Date"))
 284            ;; If we can get a link, that's awesome.
 285            (gcc (mail-fetch-field "Gcc"))
 286            (link (or (and gcc
 287                           (org-store-link nil))
 288                      nil))
 289            (group (ignore-errors (car (split-string link "#")))))
 290       ;; If we can't make a real link, then save some information so
 291       ;; we can fake it.
 292       (when in-reply-to
 293         (setq refs (concat refs " " in-reply-to)))
 294       (when refs
 295         (setq refs (gnus-extract-references refs)))
 296       (setq gnorb-gnus-message-info
 297             `(:subject ,subject :msg-id ,msg-id
 298                        :to ,to :from ,from
 299                        :link ,link :date ,date :refs ,refs
 300                        :group ,group))
 301       (if org-ids
 302           (progn
 303             (require 'gnorb-org)
 304             (setq gnorb-message-org-ids org-ids)
 305             ;; `gnorb-org-setup-message' may have put this here, but
 306             ;; if we're working from a draft, or triggering this from
 307             ;; a reply, it might not be there yet.
 308             (add-to-list 'message-send-actions
 309                          'gnorb-org-restore-after-send t))
 310         (setq gnorb-message-org-ids nil)))))
 311
 312 ;; This sets the global value, but the hook is made buffer-local in
 313 ;; `gnus-inews-add-send-actions', so this is ignored
 314 ;(add-hook 'message-header-hook 'gnorb-gnus-check-outgoing-headers)
 315 (add-hook 'message-send-hook 'gnorb-gnus-check-outgoing-headers t)
 316
 317 ;;;###autoload
 318 (defun gnorb-gnus-outgoing-do-todo (&optional arg)
 319   "Use this command to use the message currently being composed
 320 as an email todo action.
 321
 322 If it's a new message, or a reply to a message that isn't
 323 referenced by any TODOs, a new TODO will be created.
 324
 325 If it references an existing TODO, you'll be prompted to trigger
 326 a state-change or a note on that TODO after the message is sent.
 327
 328 You can call it with a prefix arg to force choosing an Org
 329 subtree to associate with.
 330
 331 If you've already called this command, but realize you made a
 332 mistake, you can call this command with a double prefix to reset
 333 the association.
 334
 335 If a new todo is made, it needs a capture template: set
 336 `gnorb-gnus-new-todo-capture-key' to the string key for the
 337 appropriate capture template. If you're using a gnus-based
 338 archive method (ie you have `gnus-message-archive-group' set to
 339 something, and your outgoing messages have a \"Fcc\" header),
 340 then a real link will be made to the outgoing message, and all
 341 the gnus-type escapes will be available (see the Info
 342 manual (org) Template expansion section). If you don't, then the
 343 %:subject, %:to, %:toname, %:toaddress, and %:date escapes for
 344 the outgoing message will still be available -- nothing else will
 345 work."
 346   (interactive "P")
 347   (let ((org-refile-targets gnorb-gnus-trigger-refile-targets)
 348         (compose-marker (make-marker))
 349         header-ids ref-ids rel-headings
 350         gnorb-window-conf in-reply-to)
 351     (when (equal arg '(4))
 352       (setq rel-headings
 353             (org-refile-get-location "Trigger action on" nil t))
 354       (setq rel-headings
 355             (list (list (save-window-excursion
 356                           (find-file (nth 1 rel-headings))
 357                           (goto-char (nth 3 rel-headings))
 358                           (org-id-get-create))))))
 359     (if (not (eq major-mode 'message-mode))
 360         ;; The message is already sent, so we're relying on whatever was
 361         ;; stored into `gnorb-gnus-message-info'.
 362         (if (equal arg '(16))
 363             (user-error "A double prefix is only useful with an
 364             unsent message.")
 365           (if arg
 366               (progn
 367                 (push (car rel-headings) gnorb-message-org-ids)
 368                 (gnorb-org-restore-after-send))
 369             (setq ref-ids (plist-get gnorb-gnus-message-info :refs))
 370             (if ref-ids
 371                 ;; the message might be relevant to some TODO
 372                 ;; heading(s). But if there had been org-id
 373                 ;; headers, they would already have been
 374                 ;; handled when the message was sent.
 375                 (progn
 376                   (setq rel-headings (gnorb-find-visit-candidates ref-ids))
 377                   (if (not rel-headings)
 378                       (gnorb-gnus-outgoing-make-todo-1)
 379                     (dolist (h rel-headings)
 380                       (push h gnorb-message-org-ids))
 381                     (gnorb-org-restore-after-send)))
 382               ;; not relevant, just make a new TODO
 383               (gnorb-gnus-outgoing-make-todo-1))))
 384       ;; We are still in the message composition buffer, so let's see
 385       ;; what we've got.
 386
 387       (if (equal arg '(16))
 388           ;; Double prefix arg means delete the association we already
 389           ;; made.
 390           (save-excursion
 391             (save-restriction
 392               (widen)
 393               (setq message-send-actions
 394                     (remove 'gnorb-gnus-outgoing-make-todo-1
 395                             message-send-actions))
 396               (message-narrow-to-headers-or-head)
 397               (message-remove-header
 398                gnorb-mail-header)
 399               (message "Message associations have been reset")))
 400         ;; Save-excursion won't work, because point will move if we
 401         ;; insert headings.
 402         (move-marker compose-marker (point))
 403         (save-restriction
 404           (widen)
 405           (message-narrow-to-headers-or-head)
 406           (setq header-ids (mail-fetch-field gnorb-mail-header nil nil t))
 407           ;; With a prefix arg we do not check references, because the
 408           ;; whole point is to add new references. We still want to know
 409           ;; what org id headers are present, though, so we don't add
 410           ;; duplicates.
 411           (setq ref-ids (unless arg (mail-fetch-field "References" t)))
 412           (setq in-reply-to (unless arg (mail-fetch-field "In-Reply-to" t)))
 413           (when in-reply-to
 414             (setq ref-ids (concat ref-ids " " in-reply-to)))
 415           (when ref-ids
 416             ;; if the References header points to any message ids that are
 417             ;; tracked by TODO headings...
 418             (setq rel-headings (gnorb-find-visit-candidates ref-ids)))
 419           (when rel-headings
 420             (goto-char (point-min))
 421             (dolist (h (delete-dups rel-headings))
 422               ;; then get the org-ids of those headings, and insert
 423               ;; them into this message as headers. If the id was
 424               ;; already present in a header, don't add it again.
 425               (unless (member h header-ids)
 426                 (goto-char (point-at-bol))
 427                 (open-line 1)
 428                 (message-insert-header
 429                  (intern gnorb-mail-header)
 430                  h)
 431                 ;; tell the rest of the function that this is a relevant
 432                 ;; message
 433                 (push h header-ids)))))
 434         (goto-char compose-marker)
 435         (unless header-ids
 436           (add-to-list 'message-send-actions
 437            'gnorb-gnus-outgoing-make-todo-1 t))
 438         (message
 439          (if header-ids
 440              "Message will trigger TODO state-changes after sending"
 441            "A TODO will be made from this message after it's sent"))))))
 442
 443 (defvar org-capture-link-is-already-stored)
 444
 445 (defun gnorb-gnus-outgoing-make-todo-1 ()
 446   (unless gnorb-gnus-new-todo-capture-key
 447     (error "No capture template key set, customize gnorb-gnus-new-todo-capture-key"))
 448   (let* ((link (plist-get gnorb-gnus-message-info :link))
 449          (group (plist-get gnorb-gnus-message-info :group))
 450          (date (plist-get gnorb-gnus-message-info :date))
 451          (date-ts (and date
 452                        (ignore-errors
 453                          (format-time-string
 454                           (org-time-stamp-format t)
 455                           (date-to-time date)))))
 456          (date-ts-ia (and date
 457                           (ignore-errors
 458                             (format-time-string
 459                              (org-time-stamp-format t t)
 460                              (date-to-time date)))))
 461          (msg-id (plist-get gnorb-gnus-message-info :msg-id))
 462          (sender (plist-get gnorb-gnus-message-info :from))
 463          (subject (plist-get gnorb-gnus-message-info :subject))
 464          ;; Convince Org we already have a link stored, even if we
 465          ;; don't.
 466          (org-capture-link-is-already-stored t))
 467     (if link
 468         ;; Even if you make a link to not-yet-sent messages, even if
 469         ;; you've saved the draft and it has a Date header, that
 470         ;; header isn't saved into the link plist. So fake that, too.
 471         (org-add-link-props
 472          :date date
 473          :date-timestamp date-ts
 474          :date-timestamp-inactive date-ts-ia
 475          :annotation link)
 476       (org-store-link-props
 477        :subject (plist-get gnorb-gnus-message-info :subject)
 478        :to (plist-get gnorb-gnus-message-info :to)
 479        :date date
 480        :date-timestamp date-ts
 481        :date-timestamp-inactive date-ts-ia
 482        :message-id msg-id
 483        :annotation link))
 484     (org-capture nil gnorb-gnus-new-todo-capture-key)
 485     (when msg-id
 486       (org-entry-put (point) gnorb-org-msg-id-key msg-id)
 487       (gnorb-registry-make-entry msg-id sender subject (org-id-get-create) group))))
 488
 489 ;;; If an incoming message should trigger state-change for a Org todo,
 490 ;;; call this function on it.
 491
 492 ;;;###autoload
 493 (defun gnorb-gnus-incoming-do-todo (arg &optional id)
 494   "Call this function from a received gnus message to store a
 495 link to the message, prompt for a related Org heading, visit the
 496 heading, and trigger an action on it \(see
 497 `gnorb-org-trigger-actions'\).
 498
 499 If you've set up message tracking \(with
 500 `gnorb-tracking-initialize'\), Gnorb can guess which Org heading
 501 you probably want to trigger, which can save some time. It does
 502 this by looking in the References header, and seeing if any of
 503 the messages referenced there are already being tracked by any
 504 headings.
 505
 506 If you mark several messages before calling this function, or
 507 call it with a numerical prefix arg, those messages will be
 508 \"bulk associated\" with the chosen Org heading: associations
 509 will be made, but you won't be prompted to trigger an action, and
 510 you'll stay in the Gnus summary buffer."
 511   (interactive "P")
 512   (when (not (memq major-mode '(gnus-summary-mode gnus-article-mode)))
 513     (user-error "Only works in gnus summary or article mode"))
 514   ;; We should only store a link if it's not already at the head of
 515   ;; `org-stored-links'. There's some duplicate storage, at
 516   ;; present. Take a look at calling it non-interactively.
 517   (setq gnorb-window-conf (current-window-configuration))
 518   (move-marker gnorb-return-marker (point))
 519   (setq gnorb-gnus-message-info nil)
 520   (let* ((articles (gnus-summary-work-articles arg))
 521          (art-no (gnus-summary-article-number))
 522          (headers (gnus-data-header
 523                    (gnus-data-find art-no)))
 524          (msg-id (mail-header-id headers))
 525          (from (mail-header-from headers))
 526          (subject (mail-header-subject headers))
 527          (date (mail-header-date headers))
 528          (to (cdr (assoc 'To (mail-header-extra headers))))
 529          (group (gnorb-get-real-group-name
 530                  gnus-newsgroup-name
 531                  art-no))
 532          (link (call-interactively 'org-store-link))
 533          (org-refile-targets gnorb-gnus-trigger-refile-targets)
 534          (ref-msg-ids (concat (mail-header-references headers) " "
 535                               msg-id))
 536          (related-headings
 537           (when (and (null id) ref-msg-ids)
 538             ;; Specifically ask for zombies, so the user has chance to
 539             ;; flush them out.
 540             (gnorb-find-tracked-headings headers t)))
 541          targ)
 542     (setq gnorb-gnus-message-info
 543           `(:subject ,subject :msg-id ,msg-id
 544                      :to ,to :from ,from
 545                      :link ,link :date ,date :refs ,ref-msg-ids
 546                      :group ,group))
 547     (gnorb-gnus-collect-all-attachments nil t)
 548     (condition-case err
 549      (if id
 550          (progn
 551            (delete-other-windows)
 552            (gnorb-trigger-todo-action nil id))
 553        ;; Flush out zombies (dead associations).
 554        (setq related-headings
 555              (cl-remove-if
 556               (lambda (h)
 557                 (when (null (org-id-find-id-file h))
 558                   (when (y-or-n-p
 559                          (format
 560                           "ID %s no longer exists, disassociate message?"
 561                           h))
 562                     (gnorb-delete-association msg-id h))))
 563               related-headings))
 564        ;; See if one of the related headings is chosen.
 565        (unless (catch 'target
 566                  (dolist (h related-headings nil)
 567                    (when (yes-or-no-p
 568                           (format "Trigger action on %s"
 569                                   (gnorb-pretty-outline h)))
 570                      (throw 'target (setq targ h)))))
 571          ;; If not, use the refile interface to choose one.
 572          (setq targ (org-refile-get-location
 573                      "Trigger heading" nil t))
 574          (setq targ
 575                (save-window-excursion
 576                  (find-file (nth 1 targ))
 577                  (goto-char (nth 3 targ))
 578                  (org-id-get-create))))
 579        ;; Either bulk associate multiple messages...
 580        (if (> (length articles) 1)
 581            (progn
 582              (dolist (a articles)
 583                (gnorb-registry-make-entry
 584                 (mail-header-id
 585                  (gnus-data-header
 586                   (gnus-data-find a)))
 587                 from subject targ group)
 588                (gnus-summary-remove-process-mark a))
 589              (message "Associated %d messages with %s"
 590                       (length articles) (gnorb-pretty-outline targ)))
 591          ;; ...or just trigger the one.
 592          (delete-other-windows)
 593          (gnorb-trigger-todo-action nil targ)))
 594      (error
 595       ;; If these are left populated after an error, it plays hell
 596       ;; with future trigger processes.
 597       (setq gnorb-gnus-message-info nil)
 598       (setq gnorb-gnus-capture-attachments nil)
 599       (signal (car err) (cdr err))))))
 600
 601 ;;;###autoload
 602 (defun gnorb-gnus-quick-reply ()
 603   "Compose a reply to the message under point, and associate both
 604 the original message and the reply with the selected heading.
 605 Take no other action.
 606
 607 Use this when you want to compose a reply to a message on the
 608 spot, and track both messages, without having to go through the
 609 hassle of triggering an action on a heading, and then starting a
 610 reply."
 611   (interactive)
 612   (when (not (memq major-mode '(gnus-summary-mode gnus-article-mode)))
 613     (user-error "Only works in gnus summary or article mode"))
 614   (let* ((art-no (gnus-summary-article-number))
 615          (headers (gnus-data-header
 616                    (gnus-data-find art-no)))
 617          (msg-id (mail-header-id headers))
 618          (from (mail-header-from headers))
 619          (subject (mail-header-subject headers))
 620          (group (gnorb-get-real-group-name
 621                  gnus-newsgroup-name
 622                  art-no))
 623          (ref-msg-ids (concat (mail-header-references headers) " "
 624                               msg-id))
 625          (related-headings
 626           (when ref-msg-ids
 627             (gnorb-find-tracked-headings headers t)))
 628          (targ (car-safe related-headings)))
 629     (if targ
 630         (let ((ret (make-marker)))
 631           ;; Assume the first heading is the one we want.
 632           (gnorb-registry-make-entry
 633            msg-id from subject targ group)
 634           (gnus-summary-wide-reply-with-original 1)
 635           (move-marker ret (point))
 636           (save-restriction
 637             (widen)
 638             (message-narrow-to-headers-or-head)
 639             (goto-char (point-min))
 640             (open-line 1)
 641             (message-insert-header
 642              (intern gnorb-mail-header) targ))
 643           (goto-char ret)
 644           (message
 645            (format "Original message and reply will be associated with %s"
 646                    (gnorb-pretty-outline targ))))
 647       (message "No associated headings found"))))
 648
 649 ;;;###autoload
 650 (defun gnorb-gnus-search-messages (str persist &optional head-text ret)
 651   "Initiate a search for gnus message links in an org subtree.
 652 The arg STR can be one of two things: an Org heading id value
 653 \(IDs should be prefixed with \"id+\"\), in which case links will
 654 be collected from that heading, or a string corresponding to an
 655 Org tags search, in which case links will be collected from all
 656 matching headings.
 657
 658 In either case, once a collection of links have been made, they
 659 will all be displayed in an ephemeral group on the \"nngnorb\"
 660 server. There must be an active \"nngnorb\" server for this to
 661 work."
 662   (interactive)
 663   (require 'nnir)
 664   (let ((nnir-address
 665          (or (gnus-method-to-server '(nngnorb))
 666              (user-error
 667               "Please add a \"nngnorb\" backend to your gnus installation.")))
 668         name method spec)
 669     (when (version= "5.13" gnus-version-number)
 670       (with-no-warnings           ; All these variables are available.
 671         (setq nnir-current-query nil
 672               nnir-current-server nil
 673               nnir-current-group-marked nil
 674               nnir-artlist nil)))
 675     ;; In 24.4, the group name is mostly decorative, but in 24.3, the
 676     ;; actual query is held there.
 677     (setq name (if (version= "5.13" gnus-version-number)
 678                    (concat "nnir:" (prin1-to-string `((query ,str))))
 679                  (if persist
 680                      (read-string
 681                       (format "Name for group (default %s): " head-text)
 682                       nil head-text t)
 683                    (concat "gnorb-" str))))
 684     (setq method (if (version= "5.13" gnus-version-number)
 685                      (list 'nnir nnir-address)
 686                    (list 'nnir "Gnorb")))
 687     (setq spec
 688           (list
 689            (cons 'nnir-specs (list (cons 'nnir-query-spec `((query . ,str)))
 690                                    (cons 'nnir-group-spec `((,nnir-address nil)))))
 691            (cons 'nnir-artlist nil)))
 692     (if persist
 693         (progn
 694           (switch-to-buffer gnus-group-buffer)
 695           (gnus-group-make-group name method nil spec)
 696           (gnus-group-select-group))
 697      (gnus-group-read-ephemeral-group name method nil ret nil nil spec))))
 698
 699 (defun gnorb-gnus-summary-mode-hook ()
 700   "Check if we've entered a Gnorb-generated group, and activate
 701   `gnorb-summary-minor-mode', if so."
 702   (let ((method (gnus-find-method-for-group gnus-newsgroup-name)))
 703     (when (string-match-p "Gnorb" (cadr method))
 704       (gnorb-summary-minor-mode))))
 705
 706 (add-hook 'gnus-summary-mode-hook #'gnorb-gnus-summary-mode-hook)
 707
 708 ;;; Automatic noticing of relevant messages
 709
 710 ;; likely hooks for the summary buffer include:
 711 ;; `gnus-parse-headers-hook'
 712
 713 ;; BBDB puts its notice stuff in the `gnus-article-prepare-hook',
 714 ;; which seems as good a spot as any.
 715
 716 (defun gnorb-gnus-hint-relevant-message ()
 717   "When opening an article buffer, check the message to see if it
 718 is relevant to any existing TODO headings. If so, flash a message
 719 to that effect. This function is added to the
 720 `gnus-article-prepare-hook'. It will only do anything if the
 721 option `gnorb-gnus-hint-relevant-article' is non-nil."
 722   (when (and gnorb-gnus-hint-relevant-article
 723              (not (memq (car (gnus-find-method-for-group
 724                               gnus-newsgroup-name))
 725                         '(nnvirtual nnir))))
 726     (let* ((headers
 727             (gnus-data-header
 728              (gnus-data-find
 729               (gnus-summary-article-number))))
 730            (assoc-heading
 731             (gnus-registry-get-id-key
 732              (gnus-fetch-original-field "message-id") 'gnorb-ids))
 733            (tracked-headings (gnorb-find-tracked-headings headers))
 734            (key
 735             (where-is-internal 'gnorb-gnus-incoming-do-todo
 736                                nil t)))
 737       (cond (assoc-heading
 738              (message "Message is associated with %s"
 739                       (gnorb-pretty-outline (car assoc-heading) t)))
 740             (tracked-headings
 741              (message "Possible relevant todo %s, trigger with %s"
 742                       (gnorb-pretty-outline (car tracked-headings) t)
 743                       (if key
 744                           (key-description key)
 745                         "M-x gnorb-gnus-incoming-do-todo")))
 746             (t nil)))))
 747
 748 (add-hook 'gnus-article-prepare-hook 'gnorb-gnus-hint-relevant-message)
 749
 750 (defun gnorb-gnus-insert-format-letter-maybe (header)
 751   (if (not (memq (car (gnus-find-method-for-group
 752                        gnus-newsgroup-name))
 753                  '(nnvirtual nnir)))
 754       (cond ((gnus-registry-get-id-key
 755               (mail-header-message-id header) 'gnorb-ids)
 756              gnorb-gnus-summary-tracked-mark)
 757             ((gnorb-find-tracked-headings header)
 758              gnorb-gnus-summary-mark)
 759             (t " "))
 760     " "))
 761
 762 (fset (intern (concat "gnus-user-format-function-"
 763                       gnorb-gnus-summary-mark-format-letter))
 764       (lambda (header)
 765         (gnorb-gnus-insert-format-letter-maybe header)))
 766
 767 ;;;###autoload
 768 (defun gnorb-gnus-view ()
 769   "Display the first relevant TODO heading for the message under point"
 770   (interactive)
 771   (let* ((headers (gnus-data-header
 772                    (gnus-data-find
 773                     (gnus-summary-article-number))))
 774          (tracked-headings
 775           (gnorb-find-tracked-headings headers)))
 776     (when tracked-headings
 777       (setq gnorb-window-conf (current-window-configuration))
 778       (move-marker gnorb-return-marker (point))
 779       (delete-other-windows)
 780       (org-id-goto (car tracked-headings)))))
 781
 782 (provide 'gnorb-gnus)
 783 ;;; gnorb-gnus.el ends here