[gnu-emacs-elpa] / packages / gnorb / gnorb-registry.el

;;; gnorb-registry.el --- Registry implementation for Gnorb

;; Copyright (C) 2014  Free Software Foundation, Inc.

;; Author: Eric Abrahamsen <eric@ericabrahamsen.net.>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Early on, Gnorb's message/todo tracking was done by relying on the
;; user to insert links to received messages into an Org heading, and
;; by automatically storing the Message-Ids of sent messages in a
;; property (`gnorb-org-msg-id-key', defaulting to GNORB_MSG_ID) on
;; the same heading. The heading could find all relevant messages by
;; combining the links (incoming) and the IDs of the Gnorb-specific
;; property (outgoing).
;;
;; In the end, this proved to be fragile and messy. Enter the
;; registry. The Gnus registry is a specialization of a general
;; "registry" library -- it's possible to roll your own. If you want
;; to track connections between messages and Org headings, it's an
;; obvious choice: Each relevant message is stored in the registry,
;; keyed on its Message-ID, and the org-ids of all relevant headings
;; are stored in a custom property, in our case gnorb-ids. This allows
;; us to keep all Gnorb-specific data in one place, without polluting
;; Org files or Gnus messages, persistent on disk, and with the added
;; bonus of providing a place to keep arbitrary additional metadata.
;;
;; The drawback is that the connections are no longer readily visible
;; to the user (they need to query the registry to see them), and it
;; becomes perhaps a bit more difficult (but only a bit) to keep
;; registry data in sync with the current state of the user's Gnus and
;; Org files. But a clear win, in the end.

;;; Code:

(require 'gnus-registry)
(require 'cl-lib)

(defgroup gnorb-registry nil
  "Gnorb's use of the Gnus registry."
  :tag "Gnorb Registry"
  :group 'gnorb)

(defun gnorb-registry-make-entry (msg-id sender subject org-id group)
  "Create a Gnus registry entry for a message, either received or
sent. Save the relevant Org ids in the 'gnorb-ids key."
  ;; This set-id-key stuff is actually horribly
  ;; inefficient.
  (when gnorb-tracking-enabled
    (gnus-registry-get-or-make-entry msg-id)
    (when sender
      (gnus-registry-set-id-key msg-id 'sender (list sender)))
    (when subject
      (gnus-registry-set-id-key msg-id 'subject (list subject)))
    (when org-id
      (let ((ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
        (unless (member org-id ids)
         (gnus-registry-set-id-key msg-id 'gnorb-ids (if (stringp org-id)
                                                         (cons org-id ids)
                                                       (append org-id ids))))))
    (when group
      (gnus-registry-set-id-key msg-id 'group (list group)))
    (gnus-registry-get-or-make-entry msg-id)))

(defun gnorb-registry-capture ()
  "When capturing from a Gnus message, add our new Org heading id
to the message's registry entry, under the 'gnorb-ids key."
  (when (and (with-current-buffer
                 (org-capture-get :original-buffer)
               (memq major-mode '(gnus-summary-mode gnus-article-mode)))
             (not org-note-abort))
    (let* ((msg-id
            (format "<%s>" (plist-get org-store-link-plist :message-id)))
           (entry (gnus-registry-get-or-make-entry msg-id))
           (org-ids
            (gnus-registry-get-id-key msg-id 'gnorb-ids))
           (new-org-id (org-id-get-create)))
      (plist-put org-capture-plist :gnorb-id new-org-id)
      (setq org-ids (cons new-org-id org-ids))
      (setq org-ids (delete-dups org-ids))
      (gnus-registry-set-id-key msg-id 'gnorb-ids org-ids))))


(defun gnorb-registry-capture-abort-cleanup ()
  (when (and (org-capture-get :gnorb-id)
             org-note-abort)
    (condition-case nil
        (let* ((msg-id (format "<%s>" (plist-get org-store-link-plist :message-id)))
               (existing-org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids))
               (org-id (org-capture-get :gnorb-id)))
          (when (member org-id existing-org-ids)
            (gnus-registry-set-id-key msg-id 'gnorb-ids
                                      (remove org-id existing-org-ids)))
          ;; FIXME: Yuck!  This will fail as soon as org-capture.el is compiled
          ;; with lexical-binding.
          (setq abort-note 'clean))
      (error
       (setq abort-note 'dirty)))))

(defun gnorb-find-visit-candidates (ids)
  "For all message-ids in IDS (which should be a list of
Message-ID strings, with angle brackets, or a single string of
Message-IDs), produce a list of Org ids for headings that are
relevant to that message."
  (let (ret-val sub-val)
    (when (stringp ids)
      (setq ids (gnus-extract-references ids)))
    (when gnorb-tracking-enabled
      (setq ids (delete-dups ids))
      (progn
        (dolist (id ids)
          (when
              (setq sub-val
                    (gnus-registry-get-id-key id 'gnorb-ids))
            (setq ret-val (append sub-val ret-val))))))
    (delete-dups ret-val)))

(defun gnorb-registry-org-id-search (id)
  "Find all messages that have the org ID in their 'gnorb-ids
key."
  (registry-search gnus-registry-db :member `((gnorb-ids ,id))))

(defun gnorb-registry-transition-from-props (arg)
  "Helper function for transitioning the old tracking system to the new.

The old system relied on storing sent message ids on relevant Org
headings, in the `gnorb-org-msg-id-key' property. The new system
uses the gnus registry to track relations between messages and
Org headings. This function will go through your agenda files,
find headings that have the `gnorb-org-msg-id-key' property set,
and create new registry entries that reflect that connection.

Call with a prefix arg to additionally delete the
`gnorb-org-msg-id-key' altogether from your Org headings. As this
function will not create duplicate registry entries, it's safe to
run it once with no prefix arg, to keep the properties in place,
and then once you're sure everything's working okay, run it again
with a prefix arg, to clean the Gnorb-specific properties from
your Org files."
  (interactive "P")
  (let ((count 0))
    (message "Collecting all relevant Org headings, this could take a while...")
    (org-map-entries
     (lambda ()
       (let ((id (org-id-get))
             (props (org-entry-get-multivalued-property
               (point) gnorb-org-msg-id-key))
             links group id)
        (when props
          ;; If the property is set, we should probably assume that any
          ;; Gnus links in the subtree are relevant, and should also be
          ;; collected and associated.
          (setq links (gnorb-scan-links
                       (org-element-property :end (org-element-at-point))
                       'gnus))
          (dolist (l (plist-get links :gnus))
            (gnorb-registry-make-entry
             (cl-second (split-string l "#")) nil nil
             id (cl-first (split-string l "#"))))
          (dolist (p props)
            (setq id )
            (gnorb-registry-make-entry p nil nil id nil)
            ;; This function will try to find the group for the message
            ;; and set that value on the registry entry if it can find
            ;; it.
            (unless (gnus-registry-get-id-key p 'group)
              (gnorb-msg-id-to-group p))
            (cl-incf count)))))
     gnorb-org-find-candidates-match
     'agenda 'archive 'comment)
    (message "Collecting all relevant Org headings, this could take a while... done")
    ;; Delete the properties if the user has asked us to do so.
    (if (equal arg '(4))
        (progn
          (dolist (f (org-agenda-files))
            (with-current-buffer (get-file-buffer f)
              (org-delete-property-globally gnorb-org-msg-id-key)))
          (message "%d entries created; all Gnorb-specific properties deleted."
                   count))
      (message "%d entries created." count))))

(provide 'gnorb-registry)