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-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'."
 115   :group 'gnorb-gnus
 116   :type 'list)
 117
 118 (defcustom gnorb-gnus-sent-groups nil
 119   "A list of strings indicating sent mail groups.
 120
 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
 128 each message."
 129   :group 'gnorb-gnus
 130   :type 'list)
 131
 132 (defvar gnorb-gnus-capture-attachments nil
 133   "Holding place for attachment names during the capture
 134   process.")
 135
 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.
 138
 139 ;;;###autoload
 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
 143   heading."
 144   (interactive "P")
 145   (gnus-article-part-wrapper n 'gnorb-gnus-attach-part))
 146
 147 ;;;###autoload
 148 (defun gnorb-gnus-mime-org-attach ()
 149   "Save the MIME part under point as an attachment to the
 150   specified org heading."
 151   (interactive)
 152   (gnus-article-check-buffer)
 153   (let ((data (get-text-property (point) 'gnus-data)))
 154     (when data
 155       (gnorb-gnus-attach-part data))))
 156
 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
 162                    (gnus-data-find
 163                     (gnus-summary-article-number))))
 164          (tracked-headings (gnorb-find-tracked-headings headers))
 165          (target-heading
 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))))
 171
 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))))
 177     (setq filename
 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)
 182     filename))
 183
 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
 188     (when capture-p
 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))
 193           mime-handles)
 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
 201                             (lambda (h)
 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)))
 207       (when mime-handles
 208         (dolist (h mime-handles)
 209           (let ((filename
 210                  (gnorb-gnus-save-part (cdr h))))
 211             (when (or capture-p store)
 212               (push filename gnorb-gnus-capture-attachments))))))))
 213
 214 ;;; Make the above work in the capture process
 215
 216 (defun gnorb-gnus-capture-attach ()
 217   (when (and (or gnorb-gnus-capture-always-attach
 218                  (org-capture-get :gnus-attachments))
 219              (with-current-buffer
 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)
 225     (map-y-or-n-p
 226      (lambda (a)
 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)))
 233
 234 (add-hook 'org-capture-mode-hook 'gnorb-gnus-capture-attach)
 235
 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!
 241     (condition-case nil
 242         (progn (org-attach-delete-all)
 243                (setq abort-note 'clean)
 244                ;; remove any gnorb-mail-header values here
 245                )
 246       (error
 247        (setq abort-note 'dirty)))))
 248
 249 (add-hook 'org-capture-prepare-finalize-hook
 250           'gnorb-gnus-capture-abort-cleanup)
 251
 252 ;;; Storing, removing, and acting on Org headers in messages.
 253
 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.")
 257
 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'."
 263   (save-restriction
 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"))
 278            (link (or (and gcc
 279                           (org-store-link nil))
 280                      nil))
 281            (group (ignore-errors (car (split-string link "#")))))
 282       ;; If we can't make a real link, then save some information so
 283       ;; we can fake it.
 284       (when in-reply-to
 285         (setq refs (concat refs " " in-reply-to)))
 286       (when refs
 287         (setq refs (gnus-extract-references refs)))
 288       (setq gnorb-gnus-message-info
 289             `(:subject ,subject :msg-id ,msg-id
 290                        :to ,to :from ,from
 291                        :link ,link :date ,date :refs ,refs
 292                        :group ,group))
 293       (if org-ids
 294           (progn
 295             (require 'gnorb-org)
 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)))))
 303
 304 (add-hook 'message-header-hook 'gnorb-gnus-check-outgoing-headers)
 305
 306 ;;;###autoload
 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.
 310
 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.
 313
 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.
 316
 317 You can call it with a prefix arg to force choosing an Org
 318 subtree to associate with.
 319
 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
 322 the association.
 323
 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
 334 work."
 335   (interactive "P")
 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))
 341       (setq rel-headings
 342             (org-refile-get-location "Trigger action on" nil t))
 343       (setq rel-headings
 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
 353             unsent message.")
 354           (if arg
 355               (progn
 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))
 359             (if ref-ids
 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.
 364                 (progn
 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
 374       ;; what we've got.
 375
 376       (if (equal arg '(16))
 377           ;; Double prefix arg means delete the association we already
 378           ;; made.
 379           (save-excursion
 380             (save-restriction
 381               (widen)
 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
 388                gnorb-mail-header)
 389               (message "Message associations have been reset")))
 390         ;; Save-excursion won't work, because point will move if we
 391         ;; insert headings.
 392         (move-marker compose-marker (point))
 393         (save-restriction
 394           (widen)
 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
 400           ;; duplicates.
 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)))
 403           (when in-reply-to
 404             (setq ref-ids (concat ref-ids " " in-reply-to)))
 405           (when ref-ids
 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)))
 409           (when rel-headings
 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))
 417                 (open-line 1)
 418                 (message-insert-header
 419                  (intern gnorb-mail-header)
 420                  h)
 421                 ;; tell the rest of the function that this is a relevant
 422                 ;; message
 423                 (push h header-ids)))))
 424         (goto-char compose-marker)
 425         (add-to-list
 426          'message-exit-actions
 427          (if header-ids
 428              'gnorb-org-restore-after-send
 429            'gnorb-gnus-outgoing-make-todo-1)
 430          t)
 431         (message
 432          (if header-ids
 433              "Message will trigger TODO state-changes after sending"
 434            "A TODO will be made from this message after it's sent"))))))
 435
 436 (defvar org-capture-link-is-already-stored)
 437
 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))
 444          (date-ts (and date
 445                        (ignore-errors
 446                          (format-time-string
 447                           (org-time-stamp-format t)
 448                           (date-to-time date)))))
 449          (date-ts-ia (and date
 450                           (ignore-errors
 451                             (format-time-string
 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
 458          ;; don't.
 459          (org-capture-link-is-already-stored t))
 460     (if link
 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.
 464         (org-add-link-props
 465          :date date
 466          :date-timestamp date-ts
 467          :date-timestamp-inactive date-ts-ia
 468          :annotation link)
 469       (org-store-link-props
 470        :subject (plist-get gnorb-gnus-message-info :subject)
 471        :to (plist-get gnorb-gnus-message-info :to)
 472        :date date
 473        :date-timestamp date-ts
 474        :date-timestamp-inactive date-ts-ia
 475        :message-id msg-id
 476        :annotation link))
 477     (org-capture nil gnorb-gnus-new-todo-capture-key)
 478     (when msg-id
 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))))
 481
 482 ;;; If an incoming message should trigger state-change for a Org todo,
 483 ;;; call this function on it.
 484
 485 ;;;###autoload
 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.
 493
 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)."
 501   (interactive "P")
 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
 511                    (gnus-data-find
 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) " "
 522                               msg-id))
 523          (related-headings
 524           (when (and (null id) ref-msg-ids)
 525             ;; Specifically ask for zombies, so the user has chance to
 526             ;; flush them out.
 527             (gnorb-find-tracked-headings headers t)))
 528          targ)
 529     (setq gnorb-gnus-message-info
 530           `(:subject ,subject :msg-id ,msg-id
 531                      :to ,to :from ,from
 532                      :link ,link :date ,date :refs ,ref-msg-ids
 533                      :group ,group))
 534     (gnorb-gnus-collect-all-attachments nil t)
 535     ;; Delete other windows, users can restore with
 536     ;; `gnorb-restore-layout'.
 537     (delete-other-windows)
 538     (if id
 539         (gnorb-trigger-todo-action arg id)
 540       ;; Flush out zombies (dead associations).
 541       (setq related-headings
 542             (cl-remove-if
 543              (lambda (h)
 544                (when (null (org-id-find-id-file h))
 545                  (when (y-or-n-p
 546                         (format
 547                          "ID %s no longer exists, disassociate message?"
 548                          h))
 549                    (gnorb-delete-association msg-id h))))
 550              related-headings))
 551       (if (catch 'target
 552             (dolist (h related-headings nil)
 553               (when (yes-or-no-p
 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)))))
 563
 564 ;;;###autoload
 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
 571 matching headings.
 572
 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
 576 work."
 577   (interactive)
 578   (require 'nnir)
 579   (let ((nnir-address
 580          (or (gnus-method-to-server '(nngnorb))
 581              (user-error
 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
 588               nnir-artlist 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)
 598        (list 'nnir "nnir"))
 599      nil
 600      ret
 601      nil nil
 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)))
 607
 608 ;;; Automatic noticing of relevant messages
 609
 610 ;; likely hooks for the summary buffer include:
 611 ;; `gnus-parse-headers-hook'
 612
 613 ;; BBDB puts its notice stuff in the `gnus-article-prepare-hook',
 614 ;; which seems as good a spot as any.
 615
 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))
 625                         '(nnvirtual nnir))))
 626     (let* ((headers
 627             (gnus-data-header
 628              (gnus-data-find
 629               (gnus-summary-article-number))))
 630            (assoc-heading
 631             (gnus-registry-get-id-key
 632              (gnus-fetch-original-field "message-id") 'gnorb-ids))
 633            (tracked-headings (gnorb-find-tracked-headings headers))
 634            (key
 635             (where-is-internal 'gnorb-gnus-incoming-do-todo
 636                                nil t))
 637            rel-headings)
 638       (cond (assoc-heading
 639              (message "Message is associated with %s"
 640                       (gnorb-pretty-outline (car assoc-heading) t)))
 641             (tracked-headings
 642              (message "Possible relevant todo %s, trigger with %s"
 643                       (gnorb-pretty-outline (car tracked-headings) t)
 644                       (if key
 645                           (key-description key)
 646                         "M-x gnorb-gnus-incoming-do-todo")))
 647             (t nil)))))
 648
 649 (add-hook 'gnus-article-prepare-hook 'gnorb-gnus-hint-relevant-message)
 650
 651 (defun gnorb-gnus-insert-format-letter-maybe (header)
 652   (if (not (memq (car (gnus-find-method-for-group
 653                        gnus-newsgroup-name))
 654                  '(nnvirtual nnir)))
 655       (if (gnorb-find-tracked-headings header)
 656           gnorb-gnus-summary-mark
 657         " ")
 658     " "))
 659
 660 (fset (intern (concat "gnus-user-format-function-"
 661                       gnorb-gnus-summary-mark-format-letter))
 662       (lambda (header)
 663         (gnorb-gnus-insert-format-letter-maybe header)))
 664
 665 ;;;###autoload
 666 (defun gnorb-gnus-view ()
 667   "Display the first relevant TODO heading for the message under point"
 668   (interactive)
 669   (let* ((headers (gnus-data-header
 670                    (gnus-data-find
 671                     (gnus-summary-article-number))))
 672          (tracked-headings
 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)))))
 679
 680 (provide 'gnorb-gnus)
 681 ;;; gnorb-gnus.el ends here