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