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

   1 ;;; gnorb-registry.el --- Registry implementation for Gnorb
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net.>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Early on, Gnorb's message/todo tracking was done by relying on the
  25 ;; user to insert links to received messages into an Org heading, and
  26 ;; by automatically storing the Message-Ids of sent messages in a
  27 ;; property (`gnorb-org-msg-id-key', defaulting to GNORB_MSG_ID) on
  28 ;; the same heading. The heading could find all relevant messages by
  29 ;; combining the links (incoming) and the IDs of the Gnorb-specific
  30 ;; property (outgoing).
  31 ;;
  32 ;; In the end, this proved to be fragile and messy. Enter the
  33 ;; registry. The Gnus registry is a specialization of a general
  34 ;; "registry" library -- it's possible to roll your own. If you want
  35 ;; to track connections between messages and Org headings, it's an
  36 ;; obvious choice: Each relevant message is stored in the registry,
  37 ;; keyed on its Message-ID, and the org-ids of all relevant headings
  38 ;; are stored in a custom property, in our case gnorb-ids. This allows
  39 ;; us to keep all Gnorb-specific data in one place, without polluting
  40 ;; Org files or Gnus messages, persistent on disk, and with the added
  41 ;; bonus of providing a place to keep arbitrary additional metadata.
  42 ;;
  43 ;; The drawback is that the connections are no longer readily visible
  44 ;; to the user (they need to query the registry to see them), and it
  45 ;; becomes perhaps a bit more difficult (but only a bit) to keep
  46 ;; registry data in sync with the current state of the user's Gnus and
  47 ;; Org files. But a clear win, in the end.
  48
  49 ;;; Code:
  50
  51 (require 'gnus-registry)
  52 (require 'cl-lib)
  53
  54 (defgroup gnorb-registry nil
  55   "Gnorb's use of the Gnus registry."
  56   :tag "Gnorb Registry"
  57   :group 'gnorb)
  58
  59 (defun gnorb-registry-make-entry (msg-id sender subject org-id group)
  60   "Create a Gnus registry entry for a message, either received or
  61 sent. Save the relevant Org ids in the 'gnorb-ids key."
  62   ;; This set-id-key stuff is actually horribly
  63   ;; inefficient.
  64   (when gnorb-tracking-enabled
  65     (gnus-registry-get-or-make-entry msg-id)
  66     (when sender
  67       (gnus-registry-set-id-key msg-id 'sender (list sender)))
  68     (when subject
  69       (gnus-registry-set-id-key msg-id 'subject (list subject)))
  70     (when org-id
  71       (let ((ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
  72         (unless (member org-id ids)
  73          (gnus-registry-set-id-key msg-id 'gnorb-ids (if (stringp org-id)
  74                                                          (cons org-id ids)
  75                                                        (append org-id ids))))))
  76     (when group
  77       (gnus-registry-set-id-key msg-id 'group (list group)))
  78     (gnus-registry-get-or-make-entry msg-id)))
  79
  80 (defun gnorb-registry-capture ()
  81   "When capturing from a Gnus message, add our new Org heading id
  82 to the message's registry entry, under the 'gnorb-ids key."
  83   (when (and (with-current-buffer
  84                  (org-capture-get :original-buffer)
  85                (memq major-mode '(gnus-summary-mode gnus-article-mode)))
  86              (not org-note-abort))
  87     (let* ((msg-id
  88             (format "<%s>" (plist-get org-store-link-plist :message-id)))
  89            (entry (gnus-registry-get-or-make-entry msg-id))
  90            (org-ids
  91             (gnus-registry-get-id-key msg-id 'gnorb-ids))
  92            (new-org-id (org-id-get-create)))
  93       (plist-put org-capture-plist :gnorb-id new-org-id)
  94       (setq org-ids (cons new-org-id org-ids))
  95       (setq org-ids (delete-dups org-ids))
  96       (gnus-registry-set-id-key msg-id 'gnorb-ids org-ids))))
  97
  98
  99 (defun gnorb-registry-capture-abort-cleanup ()
 100   (when (and (org-capture-get :gnorb-id)
 101              org-note-abort)
 102     (condition-case nil
 103         (let* ((msg-id (format "<%s>" (plist-get org-store-link-plist :message-id)))
 104                (existing-org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids))
 105                (org-id (org-capture-get :gnorb-id)))
 106           (when (member org-id existing-org-ids)
 107             (gnus-registry-set-id-key msg-id 'gnorb-ids
 108                                       (remove org-id existing-org-ids)))
 109           ;; FIXME: Yuck!  This will fail as soon as org-capture.el is compiled
 110           ;; with lexical-binding.
 111           (setq abort-note 'clean))
 112       (error
 113        (setq abort-note 'dirty)))))
 114
 115 (defun gnorb-find-visit-candidates (ids &optional include-zombies)
 116   "For all message-ids in IDS (which should be a list of
 117 Message-ID strings, with angle brackets, or a single string of
 118 Message-IDs), produce a list of Org ids for headings that are
 119 relevant to that message.
 120
 121 If optional argument INCLUDE_ZOMBIES is non-nil, return ID values
 122 even for headings that appear to no longer exist."
 123   (let (ret-val sub-val)
 124     (when (stringp ids)
 125       (setq ids (gnus-extract-references ids)))
 126     (when gnorb-tracking-enabled
 127       (setq ids (delete-dups ids))
 128       (progn
 129         (dolist (id ids)
 130           (when
 131               (setq sub-val
 132                     (gnus-registry-get-id-key id 'gnorb-ids))
 133             (setq ret-val (append sub-val ret-val))))))
 134     ;; This lets us be reasonably confident that the
 135     ;; headings still exist.
 136     (unless include-zombies
 137       (cl-remove-if-not
 138        (lambda (org-id)
 139          (org-id-find-id-file org-id))
 140        ret-val))
 141     (delete-dups ret-val)))
 142
 143 (defun gnorb-delete-association (msg-id org-id)
 144   "Disassociate a message and a headline.
 145
 146 This removes an Org heading's ORG-ID from the 'gnorb-ids key of
 147 the MSG-ID."
 148   (let ((org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
 149     (when (member org-id org-ids)
 150       (gnus-registry-set-id-key msg-id 'gnorb-ids
 151                                 (remove org-id org-ids)))))
 152
 153 (defun gnorb-delete-all-assocations (org-id)
 154   "Delete all message associations for an Org heading.
 155
 156 The heading is identified by ORG-ID. This is suitable for use
 157 after an Org heading is deleted, for instance."
 158   (let ((assoc-msgs (gnorb-registry-org-id-search org-id)))
 159     (mapcar
 160      (lambda (msg-id)
 161        (let ((org-ids
 162               (gnus-registry-get-id-key msg-id 'gnorb-ids)))
 163          (gnus-registry-set-id-key
 164           msg-id 'gnorb-ids (remove org-id org-ids))))
 165      assoc-msgs)))
 166
 167 (defun gnorb-registry-org-id-search (id)
 168   "Find all messages that have the org ID in their 'gnorb-ids
 169 key."
 170   (registry-search gnus-registry-db :member `((gnorb-ids ,id))))
 171
 172 (defun gnorb-registry-transition-from-props (arg)
 173   "Helper function for transitioning the old tracking system to the new.
 174
 175 The old system relied on storing sent message ids on relevant Org
 176 headings, in the `gnorb-org-msg-id-key' property. The new system
 177 uses the gnus registry to track relations between messages and
 178 Org headings. This function will go through your agenda files,
 179 find headings that have the `gnorb-org-msg-id-key' property set,
 180 and create new registry entries that reflect that connection.
 181
 182 Call with a prefix arg to additionally delete the
 183 `gnorb-org-msg-id-key' altogether from your Org headings. As this
 184 function will not create duplicate registry entries, it's safe to
 185 run it once with no prefix arg, to keep the properties in place,
 186 and then once you're sure everything's working okay, run it again
 187 with a prefix arg, to clean the Gnorb-specific properties from
 188 your Org files."
 189   (interactive "P")
 190   (let ((count 0))
 191     (message "Collecting all relevant Org headings, this could take a while...")
 192     (org-map-entries
 193      (lambda ()
 194        (let ((id (org-id-get))
 195              (props (org-entry-get-multivalued-property
 196                (point) gnorb-org-msg-id-key))
 197              links group id)
 198         (when props
 199           ;; If the property is set, we should probably assume that any
 200           ;; Gnus links in the subtree are relevant, and should also be
 201           ;; collected and associated.
 202           (setq links (gnorb-scan-links
 203                        (org-element-property :end (org-element-at-point))
 204                        'gnus))
 205           (dolist (l (plist-get links :gnus))
 206             (gnorb-registry-make-entry
 207              (cl-second (split-string l "#")) nil nil
 208              id (cl-first (split-string l "#"))))
 209           (dolist (p props)
 210             (setq id )
 211             (gnorb-registry-make-entry p nil nil id nil)
 212             ;; This function will try to find the group for the message
 213             ;; and set that value on the registry entry if it can find
 214             ;; it.
 215             (unless (gnus-registry-get-id-key p 'group)
 216               (gnorb-msg-id-to-group p))
 217             (cl-incf count)))))
 218      gnorb-org-find-candidates-match
 219      'agenda 'archive 'comment)
 220     (message "Collecting all relevant Org headings, this could take a while... done")
 221     ;; Delete the properties if the user has asked us to do so.
 222     (if (equal arg '(4))
 223         (progn
 224           (dolist (f (org-agenda-files))
 225             (with-current-buffer (get-file-buffer f)
 226               (org-delete-property-globally gnorb-org-msg-id-key)))
 227           (message "%d entries created; all Gnorb-specific properties deleted."
 228                    count))
 229       (message "%d entries created." count))))
 230
 231 (provide 'gnorb-registry)