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

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