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