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

   1 ;;; gnorb-utils.el --- Common utilities for all gnorb stuff.
   2
   3 ;; Copyright (C) 2014  Eric Abrahamsen
   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 (eval-when-compile
  28   (require 'cl))
  29
  30 (mailcap-parse-mimetypes)
  31
  32 (defgroup gnorb nil
  33   "Glue code between Gnus, Org, and BBDB."
  34   :tag "Gnorb")
  35
  36 (make-obsolete-variable
  37  'gnorb-trigger-todo-default
  38  "This variable has been superseded by
  39 `gnorb-org-trigger-actions'"
  40  "September 8, 2014" 'set)
  41
  42 (defun gnorb-prompt-for-bbdb-record ()
  43   "Prompt the user for a BBDB record."
  44   (let ((recs (bbdb-records))
  45         name)
  46     (while (> (length recs) 1)
  47       (setq name
  48             (completing-read
  49              (format "Filter records by regexp (%d remaining): "
  50                      (length recs))
  51              (mapcar 'bbdb-record-name recs)))
  52       (setq recs (bbdb-search recs name name name nil nil)))
  53     (if recs
  54         (car recs)
  55       (error "No matching records"))))
  56
  57 (defvar gnorb-tmp-dir (make-temp-file "emacs-gnorb" t)
  58   "Temporary directory where attachments etc are saved.")
  59
  60 (defvar gnorb-message-org-ids nil
  61   "List of Org heading IDs from the outgoing Gnus message, used
  62   to mark mail TODOs as done once the message is sent."
  63   ;; The send hook either populates this, or sets it to nil, depending
  64   ;; on whether the message in question has an Org id header. Then
  65   ;; `gnorb-org-restore-after-send' checks for it and acts
  66   ;; appropriately, then sets it to nil.
  67   )
  68
  69 (defvar gnorb-window-conf nil
  70   "Save window configurations here, for restoration after mails
  71 are sent, or Org headings triggered.")
  72
  73 (defvar gnorb-return-marker (make-marker)
  74   "Return point here after various actions, to be used together
  75 with `gnorb-window-conf'.")
  76
  77 (defcustom gnorb-mail-header "X-Org-ID"
  78   "Name of the mail header used to store the ID of a related Org
  79   heading. Only used locally: always stripped when the mail is
  80   sent."
  81   :group 'gnorb
  82   :type 'string)
  83
  84 ;;; this is just ghastly, but the value of this var is single regexp
  85 ;;; group containing various header names, and we want our value
  86 ;;; inside that group.
  87 (eval-after-load 'message
  88   `(let ((ign-headers-list
  89           (split-string message-ignored-mail-headers
  90                         "|"))
  91          (our-val (concat gnorb-mail-header "\\")))
  92      (unless (member our-val ign-headers-list)
  93        (setq ign-headers-list
  94              `(,@(butlast ign-headers-list 1) ,our-val
  95                ,@(last ign-headers-list 1)))
  96        (setq message-ignored-mail-headers
  97              (mapconcat
  98               'identity ign-headers-list "|")))))
  99
 100 ;;;###autoload
 101 (defun gnorb-restore-layout ()
 102   "Restore window layout and value of point after a Gnorb command.
 103
 104 Some Gnorb commands change the window layout (ie `gnorb-org-view'
 105 or incoming email triggering). This command restores the layout
 106 to what it was. Bind it to a global key, or to local keys in Org
 107 and Gnus and BBDB maps."
 108   (interactive)
 109   (when (window-configuration-p gnorb-window-conf)
 110     (select-frame-set-input-focus
 111      (window-configuration-frame gnorb-window-conf))
 112     (set-window-configuration gnorb-window-conf)
 113     (when (buffer-live-p (marker-buffer gnorb-return-marker))
 114       (goto-char gnorb-return-marker))))
 115
 116 (defun gnorb-bracket-message-id (id)
 117   "Ensure message-id ID is bound by angle brackets."
 118   ;; Always use a message-id with angle brackets around it.
 119   ;; `gnus-summary-goto-article' can handle either, but
 120   ;; `gnus-request-head' will fail without brackets IF you're
 121   ;; requesting from an nntp group. Mysterious.
 122   (unless (string-match "\\`<" id)
 123     (setq id (concat "<" id)))
 124   (unless (string-match ">\\'" id)
 125     (setq id (concat id ">")))
 126   id)
 127
 128 (defun gnorb-unbracket-message-id (id)
 129   "Ensure message-id ID is NOT bound by angle brackets."
 130   ;; This shit is annoying, but Org wants an id with no brackets, and
 131   ;; Gnus is safest with an id that has brackets. So here we are.
 132   (replace-regexp-in-string "\\(\\`<\\|>\\'\\)" "" id))
 133
 134 (defun gnorb-reply-to-gnus-link (link)
 135   "Start a reply to the linked message."
 136   (let* ((link (org-link-unescape link))
 137          (group (car (org-split-string link "#")))
 138          (id (gnorb-bracket-message-id
 139               (second (org-split-string link "#"))))
 140          (backend
 141           (car (gnus-find-method-for-group group))))
 142     (gnorb-follow-gnus-link group id)
 143     (call-interactively
 144      (if (eq backend 'nntp)
 145          'gnus-summary-followup-with-original
 146        'gnus-summary-wide-reply-with-original))))
 147
 148 (defun gnorb-follow-gnus-link (group id)
 149   "Be a little clever about following gnus links.
 150
 151 The goal here is reuse frames and windows as much as possible, so
 152 we're not opening multiple windows on the *Group* buffer, for
 153 instance, and messing up people's layouts. There also seems to be
 154 an issue when opening a link to a message whose *Summary* buffer
 155 is already visible: somehow, after following the link, point ends
 156 up on the message _after_ the one we want, and things go haywire.
 157
 158 So we try to be a little clever. The logical progression here is
 159 this:
 160
 161 1. If the link's target group is already open in a *Summary*
 162 buffer, just switch to that buffer (if it's visible in any frame
 163 then raise it and switch focus, otherwise pull it into the
 164 current window) and go to the message with
 165 `gnus-summary-goto-article'.
 166
 167 2. If the Gnus *Group* buffer is visible in any window or frame,
 168 raise that frame/window and give it focus before following the
 169 link.
 170
 171 3. Otherwise just follow the link as usual, in the current
 172 window."
 173   (let* ((sum-buffer (gnus-summary-buffer-name group))
 174          (target-buffer
 175           (cond
 176            ((gnus-buffer-exists-p sum-buffer)
 177             sum-buffer)
 178            ((gnus-buffer-exists-p gnus-group-buffer)
 179             gnus-group-buffer)
 180            (t nil)))
 181          (target-window (when target-buffer
 182                           (get-buffer-window target-buffer t))))
 183     (if target-window
 184         ;; Our target buffer is displayed somewhere: just go there.
 185         (progn
 186           (select-frame-set-input-focus
 187            (window-frame target-window))
 188           (switch-to-buffer target-buffer))
 189       ;; Our target buffer exists, but isn't displayed: pull it up.
 190       (if target-buffer
 191           (switch-to-buffer target-buffer)))
 192     (message "Following link...")
 193     (if (gnus-buffer-exists-p sum-buffer)
 194         (gnus-summary-goto-article id nil t)
 195       (gnorb-open-gnus-link group id))))
 196
 197 (defun gnorb-open-gnus-link (group id)
 198   "Gnorb version of `org-gnus-follow-link'."
 199   ;; We've probably already bracketed the id, but just in case this is
 200   ;; called from elsewhere...
 201   (let* ((id (gnorb-bracket-message-id id))
 202          (art-no (cdr (gnus-request-head id group)))
 203          (arts (gnus-group-unread group))
 204          success)
 205     (gnus-activate-group group)
 206     (setq success (gnus-group-read-group arts t group))
 207     (if success
 208         (gnus-summary-goto-article (or art-no id) nil t)
 209       (signal 'error "Group could not be opened."))))
 210
 211 (defun gnorb-trigger-todo-action (arg &optional id)
 212   "Do the actual restore action. Two main things here. First: if
 213 we were in the agenda when this was called, then keep us in the
 214 agenda. Then let the user choose an action from the value of
 215 `gnorb-org-trigger-actions'."
 216   (let ((agenda-p (eq major-mode 'org-agenda-mode))
 217         (action (cdr (assoc
 218                       (org-completing-read
 219                        "Action to take: "
 220                        gnorb-org-trigger-actions nil t)
 221                       gnorb-org-trigger-actions)))
 222         (root-marker (make-marker)))
 223     ;; Place the marker for the relevant TODO heading.
 224     (cond (agenda-p
 225            (setq root-marker
 226                  (copy-marker
 227                   (org-get-at-bol 'org-hd-marker))))
 228           ((derived-mode-p 'org-mode)
 229            (move-marker root-marker (point-at-bol)))
 230           (id
 231            (save-excursion
 232              (org-id-goto id)
 233              (move-marker root-marker (point-at-bol)))))
 234     (unless agenda-p
 235       (org-reveal))
 236     ;; Query about attaching email attachments. No matter what
 237     ;; happens, clear `gnorb-gnus-capture-attachments'.
 238     (unwind-protect
 239         (org-with-point-at root-marker
 240           (map-y-or-n-p
 241            (lambda (a)
 242              (format "Attach %s to heading? "
 243                      (file-name-nondirectory a)))
 244            (lambda (a) (org-attach-attach a nil 'mv))
 245            gnorb-gnus-capture-attachments
 246            '("file" "files" "attach")))
 247       (setq gnorb-gnus-capture-attachments nil))
 248     (cl-labels
 249         ((make-entry
 250           (id)
 251           (gnorb-registry-make-entry
 252            (plist-get gnorb-gnus-message-info :msg-id)
 253            (plist-get gnorb-gnus-message-info :from)
 254            (plist-get gnorb-gnus-message-info :subject)
 255            id
 256            (plist-get gnorb-gnus-message-info :group))))
 257       ;; Handle our action.
 258       (cond ((eq action 'note)
 259              (org-with-point-at root-marker
 260                (make-entry (org-id-get-create))
 261                (call-interactively 'org-add-note)))
 262             ((eq action 'todo)
 263              (if agenda-p
 264                  (progn
 265                    (org-with-point-at root-marker
 266                     (make-entry (org-id-get-create)))
 267                    (call-interactively 'org-agenda-todo))
 268                (org-with-point-at root-marker
 269                  (make-entry (org-id-get-create))
 270                  (call-interactively 'org-todo))))
 271             ((eq action 'no-associate)
 272              nil)
 273             ((eq action 'associate)
 274              (org-with-point-at root-marker
 275                (make-entry (org-id-get-create))))
 276             ((fboundp action)
 277              (org-with-point-at root-marker
 278                (make-entry (org-id-get-create))
 279                (funcall action gnorb-gnus-message-info)))))))
 280
 281 (defun gnorb-pretty-outline (id &optional kw)
 282   "Return pretty outline path of the Org heading indicated by ID.
 283
 284 If the KW argument is true, add the TODO keyword into the path."
 285   (org-with-point-at (org-id-find id t)
 286     (let ((el (org-element-at-point)))
 287       (concat
 288        (if kw
 289            (format "(%s): "
 290                    (org-element-property :todo-keyword el))
 291          "")
 292        (org-format-outline-path
 293         (append
 294          (list
 295           (file-name-nondirectory
 296            (buffer-file-name
 297             (org-base-buffer (current-buffer)))))
 298          (org-get-outline-path)
 299          (list
 300           (replace-regexp-in-string
 301            org-bracket-link-regexp
 302            "\\3" (org-element-property :raw-value el)))))))))
 303
 304 (defun gnorb-scan-links (bound &rest types)
 305   "Scan from point to BOUND looking for links of type in TYPES.
 306
 307 TYPES is a list of symbols, possible values include 'bbdb, 'mail,
 308 and 'gnus."
 309   ;; this function could be refactored somewhat -- lots of code
 310   ;; repetition. It also should be a little faster for when we're
 311   ;; scanning for gnus links only, that's a little slow. We should
 312   ;; probably use a different regexp based on the value of TYPES.
 313   ;;
 314   ;; This function should also *not* be responsible for unescaping
 315   ;; links -- we don't know what they're going to be used for, and
 316   ;; unescaped is safer.
 317   (unless (= (point) bound)
 318     (let (addr gnus mail bbdb)
 319       (while (re-search-forward org-any-link-re bound t)
 320         (setq addr (or (match-string-no-properties 2)
 321                        (match-string-no-properties 0)))
 322         (cond
 323          ((and (memq 'gnus types)
 324                (string-match "^<?gnus:" addr))
 325           (push (substring addr (match-end 0)) gnus))
 326          ((and (memq 'mail types)
 327                (string-match "^<?mailto:" addr))
 328           (push (substring addr (match-end 0)) mail))
 329          ((and (memq 'bbdb types)
 330                (string-match "^<?bbdb:" addr))
 331           (push (substring addr (match-end 0)) bbdb))))
 332       `(:gnus ,(reverse gnus) :mail ,(reverse mail) :bbdb ,(reverse bbdb)))))
 333
 334 (defun gnorb-msg-id-to-link (msg-id)
 335   "Given a message id, try to create a full org link to the
 336 message."
 337   (let ((server-group (gnorb-msg-id-to-group msg-id)))
 338     (when server-group
 339       (org-link-escape
 340        (concat server-group "#"
 341                (gnorb-unbracket-message-id msg-id))))))
 342
 343 (defun gnorb-msg-id-to-group (msg-id)
 344   "Given a message id, try to find the group it's in.
 345
 346 So far we're checking the registry, then the groups in
 347 `gnorb-gnus-sent-groups'. Use search engines? Other clever
 348 methods?"
 349   (let (candidates server-group)
 350     (setq msg-id (gnorb-bracket-message-id msg-id))
 351     (catch 'found
 352       (when gnorb-tracking-enabled
 353         ;; Make a big list of all the groups where this message might
 354         ;; conceivably be.
 355         (setq candidates
 356               (append (gnus-registry-get-id-key msg-id 'group)
 357                       gnorb-gnus-sent-groups))
 358         (while (setq server-group (pop candidates))
 359           (when (and (stringp server-group)
 360                      (not
 361                       (string-match-p
 362                        "\\(nnir\\|nnvirtual\\|UNKNOWN\\)"
 363                        server-group))
 364                      (ignore-errors
 365                        (gnus-request-head msg-id server-group)))
 366                 (throw 'found server-group))))
 367       (when (featurep 'notmuch)
 368         nil))))
 369
 370 (defun gnorb-collect-ids (&optional id)
 371   "Collect all Org IDs for a subtree.
 372
 373 Starting with the heading under point (or the heading indicated
 374 by the ID argument), collect its ID property, and the IDs of all
 375 child headings."
 376   (save-excursion
 377     (save-restriction
 378       (when id
 379         (org-id-goto id))
 380       (org-narrow-to-subtree)
 381       (org-element-map (org-element-parse-buffer)
 382           'headline
 383         (lambda (hl)
 384           (org-element-property :ID hl))))))
 385
 386 ;; Common functions for extracting references and relevant headings
 387 ;; from the message under point. For use in gnorb-gnus.el functions.
 388
 389 (defun gnorb-find-tracked-headings (headers &optional include-zombies)
 390   "Check HEADERS for message references and return relevant heading IDs.
 391
 392 HEADERs is a message's data header, as produced by
 393 \(gnus-interactive \"H\"\), or, equivalently:
 394
 395 \(gnus-data-header \(gnus-data-find \(gnus-summary-article-number\)\)\)"
 396   (let ((references (mail-header-references headers))
 397         (msg-id (mail-header-message-id headers)))
 398     (when gnorb-tracking-enabled
 399       (gnorb-find-visit-candidates
 400        (concat msg-id " " references) include-zombies))))
 401
 402 (defun gnorb-choose-trigger-heading (&optional id)
 403   "Given an Org heading ID, ask the user if they want to trigger it.
 404
 405 If not, prompt for another target heading. Either way, return the
 406 target heading id."
 407   (let ((id (if (stringp id)
 408                 id
 409               (car-safe id)))
 410         refile-result)
 411     (if (and id
 412              (y-or-n-p (message
 413                         "Attach part to %s"
 414                         (gnorb-pretty-outline id))))
 415         id
 416       (setq refile-result
 417             (org-refile-get-location "Attach part to" nil t))
 418       (save-window-excursion
 419         (find-file (nth 1 refile-result))
 420         (goto-char (nth 3 refile-result))
 421         (org-id-get-create)))))
 422
 423 ;; Loading the registry
 424
 425 (defvar gnorb-tracking-enabled nil
 426   "Internal flag indicating whether Gnorb is successfully plugged
 427   into the registry or not.")
 428
 429 ;;;###autoload
 430 (defun gnorb-tracking-initialize ()
 431   "Start using the Gnus registry to track correspondences between
 432 Gnus messages and Org headings. This requires that the Gnus
 433 registry be in use, and should be called after the call to
 434 `gnus-registry-initialize'."
 435   (require 'gnorb-registry)
 436   (with-eval-after-load 'gnus-registry
 437     (add-to-list 'gnus-registry-extra-entries-precious 'gnorb-ids)
 438     (add-to-list 'gnus-registry-track-extra 'gnorb-ids))
 439   (add-hook
 440    'gnus-started-hook
 441    (lambda ()
 442      (unless (gnus-registry-install-p)
 443        (user-error "Gnorb tracking requires that the Gnus registry be installed."))
 444      (add-hook 'org-capture-mode-hook 'gnorb-registry-capture)
 445      (add-hook 'org-capture-prepare-finalize-hook 'gnorb-registry-capture-abort-cleanup)
 446      (setq gnorb-tracking-enabled t))))
 447
 448 (provide 'gnorb-utils)
 449 ;;; gnorb-utils.el ends here