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

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