[elpa] externals/gnorb 9fff78a 057/449: Changing email TODO handling to operate by org ID

[Stefan Monnier]

branch: externals/gnorb
commit 9fff78af15a2251d74bb91193b2b7a0889577a20
Author: Eric Abrahamsen <eric@ericabrahamsen.net>
Commit: Eric Abrahamsen <eric@ericabrahamsen.net>

    Changing email TODO handling to operate by org ID
    
    gnorb-utils.el: new var gnorb-message-org-ids
    
    Instead of marking mail TODOs as done based only on position of point in
    a window configuration, we now stick the TODO's ID value into the
    message as a custom header. When the mail is sent, the custom header is
    stripped, and the user returned to the TODO with the matching ID. should
    be a little more robust.
---
 lisp/gnorb-gnus.el  |  37 +++++++++++++++
 lisp/gnorb-org.el   | 127 +++++++++++++++++++++++++++++++++++-----------------
 lisp/gnorb-utils.el |   9 ++++
 3 files changed, 131 insertions(+), 42 deletions(-)

diff --git a/lisp/gnorb-gnus.el b/lisp/gnorb-gnus.el
index d6e0d0b..f94a0ea 100644
--- a/lisp/gnorb-gnus.el
+++ b/lisp/gnorb-gnus.el
@@ -174,5 +174,42 @@ save them into `gnorb-tmp-dir'."
 (add-hook 'org-capture-prepare-finalize-hook
          'gnorb-gnus-capture-abort-cleanup)
 
+;;; Storing, removing, and acting on Org headers in messages.
+
+(defcustom gnorb-gnus-org-header "X-Org-ID"
+  "Name of the mail header used to store the ID of a related Org
+  heading. Only used locally: always stripped when the mail is
+  sent."
+  :group 'gnorb-gnus
+  :type 'string)
+
+;;; this is just ghastly, but the value of this var is single regexp
+;;; group containing various header names, and we want our value
+;;; inside that group.
+(eval-after-load "message"
+  (let ((ign-headers-list
+        (org-split-string message-ignored-mail-headers
+                          "|"))
+       (our-val (concat gnorb-org-mail-header "\\")))
+    (unless (member our-val ign-headers-list)
+      (setq ign-headers-list
+           `(,@(butlast ign-headers-list 1) ,our-val
+             ,@(last ign-headers-list 1)))
+      (setq message-ignored-mail-headers
+           (mapconcat
+            'identity ign-headers-list "|")))))
+
+(defun gnorb-gnus-check-org-header ()
+  "Return the value of the `gnorb-gnus-org-header' for the
+current message; multiple header values returned as a string."
+  (save-restriction
+    (message-narrow-to-headers)
+    (let ((org-ids (mail-fetch-field gnorb-gnus-org-header nil nil t)))
+      (if org-ids
+         (setq gnorb-message-org-ids org-ids)
+       (setq gnorb-message-org-ids nil)))))
+
+(add-hook 'message-send-hook 'gnorb-gnus-check-org-header)
+
 (provide 'gnorb-gnus)
 ;;; gnorb-gnus.el ends here
diff --git a/lisp/gnorb-org.el b/lisp/gnorb-org.el
index 920f84e..4f41da6 100644
--- a/lisp/gnorb-org.el
+++ b/lisp/gnorb-org.el
@@ -55,28 +55,43 @@ point."
   after the mail is sent.")
 
 (defun gnorb-org-restore-after-send ()
-  (when (eq major-mode 'gnus-summary-exit)
+  (when (eq major-mode 'gnus-summary-mode)
     (gnus-summary-exit nil t))
+  ;; this var would have been set in `gnorb-gnus-check-org-header',
+  ;; which was run during `message-send-hook'
+  (when gnorb-message-org-ids
+    (dolist (id gnorb-message-org-ids)
+      (with-demoted-errors
+       (org-id-goto id)
+       (delete-other-windows)
+       (when (or (null gnorb-org-mail-todos)
+                 (member (org-entry-get (point) "TODO")
+                         gnorb-org-mail-todos))
+         (call-interactively 'org-todo)))))
   (when (window-configuration-p gnorb-org-window-conf)
     (set-window-configuration gnorb-org-window-conf))
-  (cond ((eq major-mode 'org-agenda-mode)
-        (if (null gnorb-org-mail-todos)
-            (call-interactively 'org-agenda-todo)
-          (let* ((marker (or (org-get-at-bol 'org-marker)
-                             (org-agenda-error)))
-                 (buffer (marker-buffer marker)))
-            (when (save-excursion
-                    (with-current-buffer buffer
-                      (goto-char (marker-position marker))
-                      (member (org-entry-get (point) "TODO")
-                              gnorb-org-mail-todos)))
-              (call-interactively 'org-agenda-todo)))))
-       ((eq major-mode 'org-mode)
-        (when (or (null gnorb-org-mail-todos)
-                  (member (org-entry-get (point) "TODO")
-                          gnorb-org-mail-todos))
-          (call-interactively 'org-todo)))
-       (t nil)))
+  ;; this is a little unnecessary, but still...
+  (setq gnorb-org-window-conf nil)
+  (setq gnorb-message-org-ids nil))
+
+   ;; (cond ((eq major-mode 'org-agenda-mode)
+   ;;    (if (null gnorb-org-mail-todos)
+   ;;        (call-interactively 'org-agenda-todo)
+   ;;      (let* ((marker (or (org-get-at-bol 'org-marker)
+   ;;                         (org-agenda-error)))
+   ;;             (buffer (marker-buffer marker)))
+   ;;        (when (save-excursion
+   ;;                (with-current-buffer buffer
+   ;;                  (goto-char (marker-position marker))
+   ;;                  (member (org-entry-get (point) "TODO")
+   ;;                          gnorb-org-mail-todos)))
+   ;;          (call-interactively 'org-agenda-todo)))))
+   ;;   ((eq major-mode 'org-mode)
+   ;;    (when (or (null gnorb-org-mail-todos)
+   ;;              (member (org-entry-get (point) "TODO")
+   ;;                      gnorb-org-mail-todos))
+   ;;      (call-interactively 'org-todo)))
+   ;;   (t nil))
 
 (defun gnorb-org-extract-mail-stuff ()
   (let (message mails)
@@ -97,43 +112,65 @@ point."
                (push mail mails))))))))
     (list message mails)))
 
-(defun gnorb-org-setup-message (&optional messages mails attachments text)
-  "Common message setup routine for other gnorb-org commands."
+(defun gnorb-org-setup-message (&optional messages mails attachments text ids)
+  "Common message setup routine for other gnorb-org commands.
+MESSAGES is a list of gnus links pointing to messages -- we
+currently only use the first of the list. MAILS is a list of
+email address strings suitable for inserting in the To header.
+ATTACHMENTS is a list of filenames to attach. TEXT is a string or
+buffer, which is inserted in the message body. IDS is one or more
+Org heading ids, associating the outgoing message with those
+headings."
+  (require 'gnorb-gnus)
   (if (not messages)
       ; either compose new message...
-      (compose-mail (mapconcat 'identity mails ", ")
-                   nil nil nil nil nil nil
-                   '(gnorb-org-restore-after-send))
+      (compose-mail (mapconcat 'identity mails ", "))
     ; ...or follow link and start reply
-    (org-gnus-open (org-link-unescape (car messages)))
-    (call-interactively
-     'gnus-summary-wide-reply-with-original)
-    ; add MAILS to message To header
-    (when mails
-      (message-goto-to)
-      (insert ", ")
-      (insert (mapconcat 'identity mails ", ")))
-    (add-to-list 'message-exit-actions
-                'gnorb-org-restore-after-send t))
+    (condition-case nil
+       (progn
+         (org-gnus-open (org-link-unescape (car messages)))
+         (call-interactively
+          'gnus-summary-wide-reply-with-original)
+         ;; add MAILS to message To header
+         (when mails
+           (message-goto-to)
+           (insert ", ")
+           (insert (mapconcat 'identity mails ", "))))
+      (error (message "Couldn't open linked message"))))
+  ;; return us after message is sent
+  (add-to-list 'message-exit-actions
+              'gnorb-org-restore-after-send t)
   ; attach ATTACHMENTS
   (map-y-or-n-p
    (lambda (a) (format "Attach %s to outgoing message? "
                       (file-name-nondirectory a)))
    (lambda (a)
-     (mml-attach-file
-      a (mm-default-file-encoding a)
+     (mml-attach-file a (mm-default-file-encoding a)
       nil "attachment"))
    attachments
    '("file" "files" "attach"))
-  ; insert text, if any
+  ;; insert text, if any
   (when text
     (message-goto-body)
     (insert"\n")
     (if (bufferp text)
        (insert-buffer text)
       (insert text)))
+  ;; insert org ids, if any
+  (when ids
+    (unless (listp ids)
+      (setq ids (list ids)))
+    (save-excursion
+      (save-restriction
+       (message-narrow-to-headers)
+       (dolist (i ids)
+         (goto-char (point-at-bol))
+         (open-line 1)
+         ;; this function hardly does anything
+         (message-insert-header
+          (intern gnorb-gnus-org-header) i)))))
   ; put point somewhere reasonable
-  (if (or mails message)
+  (if (or mails messages)
       (message-goto-body)
     (message-goto-to)))
 
@@ -165,10 +202,11 @@ current heading."
   (unless (org-back-to-heading t)
     (error "Not in an org item"))
   (let ((mail-stuff (gnorb-org-extract-mail-stuff))
-       (attachments (gnorb-org-attachment-list)))
+       (attachments (gnorb-org-attachment-list))
+       (org-id (org-id-get-create)))
     (gnorb-org-setup-message
      (first mail-stuff) (second mail-stuff)
-     attachments)))
+     attachments nil org-id)))
 
 ;;; Email subtree
 
@@ -252,6 +290,7 @@ default set of parameters."
                     ,gnorb-org-email-subtree-parameters))))
         (mail-stuff (gnorb-org-extract-mail-stuff))
         (attachments (gnorb-org-attachment-list))
+        (org-id (org-id-get-create))
         text)
     (setq gnorb-org-window-conf (current-window-configuration))
     (if (bufferp result)
@@ -259,7 +298,7 @@ default set of parameters."
       (push result attachments))
     (gnorb-org-setup-message
      (first mail-stuff) (second mail-stuff)
-     attachments text)))
+     attachments text org-id)))
 
 (defcustom gnorb-org-capture-collect-link-p t
   "Should the capture process store a link to the gnus message or
@@ -279,6 +318,8 @@ default set of parameters."
 
 (add-hook 'org-capture-mode-hook 'gnorb-org-capture-collect-link)
 
+;;; Agenda/BBDB popup stuff
+
 (defcustom gnorb-org-agenda-popup-bbdb nil
   "Should Agenda tags search pop up a BBDB buffer with matching
   records?
@@ -346,7 +387,9 @@ search."
                recs gnorb-org-bbdb-popup-layout)
        (when (get-buffer-window bbdb-buffer-name)
          (quit-window nil
-                      (get-buffer-window bbdb-buffer-name)))))))
+                      (get-buffer-window bbdb-buffer-name)))
+       (when (called-interactively-p)
+         (message "No relevant BBDB records"))))))
 
 (add-hook 'org-agenda-finalize-hook 'gnorb-org-agenda-popup-bbdb)
 
diff --git a/lisp/gnorb-utils.el b/lisp/gnorb-utils.el
index 1f7d05f..535082f 100644
--- a/lisp/gnorb-utils.el
+++ b/lisp/gnorb-utils.el
@@ -54,5 +54,14 @@
 (defvar gnorb-tmp-dir (make-temp-file "emacs-gnorb" t)
   "Temporary directory where attachments etc are saved.")
 
+(defvar gnorb-message-org-ids nil
+  "List of Org heading IDs from the outgoing Gnus message, used
+  to mark mail TODOs as done once the message is sent."
+  ;; The send hook either populates this, or sets it to nil, depending
+  ;; on whether the message in question has an Org id header. Then
+  ;; `gnorb-org-restore-after-send' checks for it and acts
+  ;; appropriately.
+)
+
 (provide 'gnorb-utils)
 ;;; gnorb-utils.el ends here