1 ;;; gnorb-registry.el --- Registry implementation for Gnorb
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net.>
7 ;; This file is part of GNU Emacs.
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.
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.
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/>.
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).
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.
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.
51 (require 'gnus-registry)
52 (require 'gnorb-utils)
55 (defgroup gnorb-registry nil
56 "Gnorb's use of the Gnus registry."
60 (defun gnorb-registry-make-entry (msg-id sender subject org-id group)
61 "Create a Gnus registry entry for a message, either received or
62 sent. Save the relevant Org ids in the 'gnorb-ids key."
63 ;; This set-id-key stuff is actually horribly
65 (when gnorb-tracking-enabled
66 (gnus-registry-get-or-make-entry msg-id)
68 (gnus-registry-set-id-key msg-id 'sender (list sender)))
70 (gnus-registry-set-id-key msg-id 'subject (list subject)))
72 (let ((ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
73 (unless (member org-id ids)
74 (gnus-registry-set-id-key msg-id 'gnorb-ids (if (stringp org-id)
76 (append org-id ids))))))
78 (gnus-registry-set-id-key msg-id 'group (list group)))
79 (gnus-registry-get-or-make-entry msg-id)))
81 (defun gnorb-registry-capture ()
82 "When capturing from a Gnus message, add our new Org heading id
83 to the message's registry entry, under the 'gnorb-ids key."
84 (when (and (with-current-buffer
85 (org-capture-get :original-buffer)
86 (memq major-mode '(gnus-summary-mode gnus-article-mode)))
89 (gnorb-bracket-message-id
90 (plist-get org-store-link-plist :message-id)))
91 (org-id (org-id-get-create)))
92 (plist-put org-capture-plist :gnorb-id org-id)
93 (gnorb-registry-make-entry msg-id nil nil org-id nil))))
96 (defun gnorb-registry-capture-abort-cleanup ()
97 (when (and (org-capture-get :gnorb-id)
99 (with-no-warnings ; For `abort-note'
100 (condition-case error
101 (let* ((msg-id (format "<%s>" (plist-get org-store-link-plist :message-id)))
102 (existing-org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids))
103 (org-id (org-capture-get :gnorb-id)))
104 (when (member org-id existing-org-ids)
105 (gnus-registry-set-id-key msg-id 'gnorb-ids
106 (remove org-id existing-org-ids)))
107 (setq abort-note 'clean))
109 (setq abort-note 'dirty))))))
111 (defun gnorb-find-visit-candidates (ids &optional include-zombies)
112 "For all message-ids in IDS (which should be a list of
113 Message-ID strings, with angle brackets, or a single string of
114 Message-IDs), produce a list of Org ids for headings that are
115 relevant to that message.
117 If optional argument INCLUDE_ZOMBIES is non-nil, return ID values
118 even for headings that appear to no longer exist."
119 (let (ret-val sub-val)
121 (setq ids (gnus-extract-references ids)))
122 (when gnorb-tracking-enabled
123 (setq ids (delete-dups ids))
128 (gnus-registry-get-id-key id 'gnorb-ids))
129 (setq ret-val (append sub-val ret-val))))))
130 ;; This lets us be reasonably confident that the
131 ;; headings still exist.
132 (unless include-zombies
135 (org-id-find-id-file org-id))
137 (delete-dups ret-val)))
139 (defun gnorb-delete-association (msg-id org-id)
140 "Disassociate a message and a headline.
142 This removes an Org heading's ORG-ID from the 'gnorb-ids key of
144 (let ((org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
145 (when (member org-id org-ids)
146 (gnus-registry-set-id-key msg-id 'gnorb-ids
147 (remove org-id org-ids)))))
149 (defun gnorb-delete-all-associations (org-id)
150 "Delete all message associations for an Org heading.
152 The heading is identified by ORG-ID. This is suitable for use
153 after an Org heading is deleted, for instance."
154 (let ((assoc-msgs (gnorb-registry-org-id-search org-id))
156 (registry-lookup-secondary gnus-registry-db 'gnorb-ids)))
160 (gnus-registry-get-id-key msg-id 'gnorb-ids)))
161 (gnus-registry-set-id-key
162 msg-id 'gnorb-ids (remove org-id org-ids))))
164 (remhash org-id gnorb-id-tracker)))
166 (defun gnorb-flush-dead-associations (&optional clean-archived)
167 "Clean the registry of associations with nonexistent headings.
169 Gnus will not prune registry entries that appear to be associated
170 with an Org heading. If your registry is limited to a very small
171 size, you may end up with a full registry. Use this function to
172 remove dead associations, and free up more entries for possible
175 By default, associations are considered \"live\" if the Org
176 heading exists in an Org file or in an Org archive file. When
177 optional CLEAN_ARCHIVED is non-nil, delete associations from
178 archived headings as well."
180 (let ((gnorb-id-tracker
181 (registry-lookup-secondary gnus-registry-db 'gnorb-ids))
186 (let ((file (org-id-find-id-file k)))
189 (string-match-p "org_archive$" file)))
190 (gnorb-delete-all-associations k)
191 (incf deleted-count))))
193 (message "Deleted %d invalid associations"
196 (defun gnorb-registry-org-id-search (id)
197 "Find all messages that have the org ID in their 'gnorb-ids
199 (registry-search gnus-registry-db :member `((gnorb-ids ,id))))
201 (defun gnorb-registry-tracked-messages ()
202 "Return all message-ids that have non-empty 'gnorb-ids keys."
203 (registry-search gnus-registry-db :regex `((gnorb-ids ".+"))))
205 (defun gnorb-registry-tracked-headings ()
206 "Return all Org heading ids that are associated with messages."
208 (registry-lookup-secondary gnus-registry-db 'gnorb-ids)))
210 (defun gnorb-report-tracking-usage ()
211 "Pop up a temporary window reporting on Gnorb usage of the Gnus
212 registry to track message/heading associations. Reports the
213 number of tracked messages, the number of tracked headings, and how much of the registry is occupied."
217 (get-buffer-create "*Gnorb Usage*")
218 '(nil . ((window-height . 10))))
219 (gnorb-refresh-usage-status)
221 (setq revert-buffer-function #'gnorb-refresh-usage-status)
222 (local-set-key (kbd "d") (lambda ()
225 (gnorb-flush-dead-associations)
226 (gnorb-refresh-usage-status))))
227 (local-set-key (kbd "D") (lambda ()
230 (gnorb-flush-dead-associations t)
231 (gnorb-refresh-usage-status))))))
233 (defun gnorb-refresh-usage-status (&optional ignore-auto noconfirm)
234 "Clear and re-format the *Gnorb Usage* buffer."
235 (let ((messages (length (gnorb-registry-tracked-messages)))
236 (headings (length (gnorb-registry-tracked-headings)))
237 (reg-size (registry-size gnus-registry-db))
238 (reg-max-size (oref gnus-registry-db max-size)))
239 (with-current-buffer "*Gnorb Usage*"
240 (let ((inhibit-read-only t))
244 "Tracking %d Gnus messages associated with %d Org headings."
249 "Occupying %.2f%% (%d/%d) of the registry (max %d)."
250 (* 100 (/ (float messages) reg-size))
251 messages reg-size reg-max-size))
253 (insert "Press 'd' to delete associations for non-existent Org headings.\n")
254 (insert "Press 'D' to delete associations for both non-existent and archived Org headings.")))))
256 (defun gnorb-registry-transition-from-props (arg)
257 "Helper function for transitioning the old tracking system to the new.
259 The old system relied on storing sent message ids on relevant Org
260 headings, in the `gnorb-org-msg-id-key' property. The new system
261 uses the gnus registry to track relations between messages and
262 Org headings. This function will go through your agenda files,
263 find headings that have the `gnorb-org-msg-id-key' property set,
264 and create new registry entries that reflect that connection.
266 Call with a prefix arg to additionally delete the
267 `gnorb-org-msg-id-key' altogether from your Org headings. As this
268 function will not create duplicate registry entries, it's safe to
269 run it once with no prefix arg, to keep the properties in place,
270 and then once you're sure everything's working okay, run it again
271 with a prefix arg, to clean the Gnorb-specific properties from
275 (message "Collecting all relevant Org headings, this could take a while...")
278 (let ((id (org-id-get))
279 (props (org-entry-get-multivalued-property
280 (point) gnorb-org-msg-id-key))
283 ;; If the property is set, we should probably assume that any
284 ;; Gnus links in the subtree are relevant, and should also be
285 ;; collected and associated.
286 (setq links (gnorb-scan-links
287 (org-element-property :end (org-element-at-point))
289 (dolist (l (plist-get links :gnus))
290 (gnorb-registry-make-entry
291 (cl-second (split-string l "#")) nil nil
292 id (cl-first (split-string l "#"))))
295 (gnorb-registry-make-entry p nil nil id nil)
296 ;; This function will try to find the group for the message
297 ;; and set that value on the registry entry if it can find
299 (unless (gnus-registry-get-id-key p 'group)
300 (gnorb-msg-id-to-group p))
302 gnorb-org-find-candidates-match
303 'agenda 'archive 'comment)
304 (message "Collecting all relevant Org headings, this could take a while... done")
305 ;; Delete the properties if the user has asked us to do so.
308 (dolist (f (org-agenda-files))
309 (with-current-buffer (get-file-buffer f)
310 (org-delete-property-globally gnorb-org-msg-id-key)))
311 (message "%d entries created; all Gnorb-specific properties deleted."
313 (message "%d entries created." count))))
315 (provide 'gnorb-registry)