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

   1 ;;; nngnorb.el --- Gnorb backend for Gnus
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net.>
   6
   7 ;; This file is part of GNU Emacs.
   8
   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.
  13
  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.
  18
  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/>.
  21
  22 ;;; Commentary:
  23
  24 ;; This is a backend for supporting Gnorb-related stuff. I'm going to
  25 ;; regret this, I know.
  26
  27 ;; It started off just with wanting to collect all the gnus links in a
  28 ;; subtree, and display all the messages in an ephemeral group. But it
  29 ;; doesn't seem possible to create ephemeral groups without
  30 ;; associating them with a server, and which server would that be?
  31 ;; Nnir also provides a nice interface to creating ephemeral groups,
  32 ;; but again, it relies on a server parameter to know which nnir
  33 ;; engine to use, and if you try to fake it it still craps out.
  34
  35 ;; So this file is a copy-pasta from nnnil.el -- I'm trying to keep
  36 ;; this as simple as possible. Right now it does nothing but serving
  37 ;; as a place to hang ephemeral groups made with nnir searches of
  38 ;; message from the rest of your gnus installation. Enjoy.
  39
  40 ;;; Code:
  41
  42 (require 'gnus)
  43 (eval-and-compile
  44   (require 'nnheader)
  45   (require 'nnir))
  46
  47 (defvar nngnorb-status-string "")
  48
  49 (defvar nngnorb-attachment-file-list nil
  50   "A place to store Org attachments relevant to the subtree being
  51   viewed.")
  52
  53 (make-variable-buffer-local 'nngnorb-attachment-file-list)
  54
  55 (gnus-declare-backend "nngnorb" 'post-mail 'virtual)
  56
  57 (add-to-list 'nnir-method-default-engines '(nngnorb . gnorb))
  58
  59 (add-to-list 'nnir-engines
  60              '(gnorb nnir-run-gnorb))
  61
  62 (defun nnir-run-gnorb (query server &optional group)
  63   "Run the actual search for messages to display. See nnir.el for
  64 some details of how this gets called.
  65
  66 As things stand, the query string can be given as one of two
  67 different things. First is the ID string of an Org heading,
  68 prefixed with \"id+\". This was probably a bad choice as it could
  69 conceivably look like an org tags search string. Fix that later.
  70 If it's an ID, then the entire subtree text of that heading is
  71 scanned for gnus links, and the messages relevant to the subtree
  72 are collected from the registry, and all the resulting messages
  73 are displayed in an ephemeral group.
  74
  75 Otherwise, the query string can be a tags match string, a la the
  76 Org agenda tags search. All headings matched by this string will
  77 be scanned for gnus messages, and those messages displayed."
  78   ;; During the transition period between using message-ids stored in
  79   ;; a property, and the new registry-based system, we're going to use
  80   ;; both methods to collect relevant messages. This could be a little
  81   ;; slower, but for the time being it will be safer.
  82   (save-window-excursion
  83     (let ((q (cdr (assq 'query query)))
  84           (buf (get-buffer-create nnir-tmp-buffer))
  85           msg-ids org-ids links vectors)
  86       (with-current-buffer buf
  87         (erase-buffer)
  88         (setq nngnorb-attachment-file-list nil))
  89       (when (and (equal "5.13" gnus-version-number) (version< emacs-version "24.4"))
  90         (setq q (car q)))
  91       (cond ((string-match "id\\+\\([[:alnum:]-]+\\)$" q)
  92              (with-demoted-errors "Error: %S"
  93                (org-id-goto (match-string 1 q))
  94                (append-to-buffer
  95                 buf
  96                 (point)
  97                 (org-element-property
  98                  :end (org-element-at-point)))
  99                (save-restriction
 100                  (org-narrow-to-subtree)
 101                  (setq org-ids
 102                        (append
 103                         (gnorb-collect-ids)
 104                         org-ids))
 105                  (when org-ids
 106                    (with-current-buffer buf
 107                      ;; The file list var is buffer local, so set it
 108                      ;; (local to the nnir-tmp-buffer) to a full list
 109                      ;; of all files in the subtree.
 110                      (dolist (id org-ids)
 111                        (setq nngnorb-attachment-file-list
 112                              (append (gnorb-org-attachment-list id)
 113                                      nngnorb-attachment-file-list))))))))
 114             ((listp q)
 115              ;; be a little careful: this could be a list of links, or
 116              ;; it could be the full plist
 117              (setq links (if (plist-member q :gnus)
 118                              (plist-get q :gnus)
 119                            q)))
 120             (t (org-map-entries
 121                 (lambda ()
 122                   (push (org-id-get) org-ids)
 123                   (append-to-buffer
 124                    buf
 125                    (point)
 126                    (save-excursion
 127                      (outline-next-heading)
 128                      (point))))
 129                 q
 130                 'agenda)))
 131       (with-current-buffer buf
 132         (goto-char (point-min))
 133         (setq links (plist-get (gnorb-scan-links (point-max) 'gnus)
 134                                :gnus))
 135         (goto-char (point-min))
 136         (while (re-search-forward
 137                 (concat ":" gnorb-org-msg-id-key ": \\([^\n]+\\)")
 138                 (point-max) t)
 139           (setq msg-ids (append (split-string (match-string 1)) msg-ids))))
 140       ;; Here's where we maybe do some duplicate work using the
 141       ;; registry. Take our org ids and find all relevant message ids.
 142       (dolist (i (delq nil org-ids))
 143         (let ((rel-msg-id (gnorb-registry-org-id-search i)))
 144           (when rel-msg-id
 145             (setq msg-ids (append (delq nil rel-msg-id) msg-ids)))))
 146       (when msg-ids
 147           (dolist (id msg-ids)
 148             (let ((link (gnorb-msg-id-to-link id)))
 149               (when link
 150                 (push link links)))))
 151       (setq links (delete-dups links))
 152       (unless (gnus-alive-p)
 153         (gnus))
 154       (dolist (m links (when vectors
 155                          (nreverse vectors)))
 156         (let (server-group msg-id result artno)
 157           (setq m (org-link-unescape m))
 158           (when (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" m)
 159             (setq server-group (match-string 1 m)
 160                   msg-id (gnorb-bracket-message-id
 161                           (match-string 3 m))
 162                   result (ignore-errors (gnus-request-head msg-id server-group)))
 163             (when result
 164              (setq artno (cdr result))
 165              (when (and (integerp artno) (> artno 0))
 166                (push (vector server-group artno 100) vectors)))))))))
 167
 168 (defvar gnorb-summary-minor-mode-map (make-sparse-keymap)
 169   "Keymap for use in Gnorb's *Summary* minor mode.")
 170
 171 (define-minor-mode gnorb-summary-minor-mode
 172   "A minor mode for use in nnir *Summary* buffers created by Gnorb.
 173
 174 These *Summary* buffers are usually created by calling
 175 `gnorb-org-view', or by initiating an nnir search on a nngnorb server.
 176
 177 While active, this mode provides some Gnorb-specific commands,
 178 and also advises Gnus' reply-related commands in order to
 179 continue to provide tracking of sent messages."
 180   nil " Gnorb" gnorb-summary-minor-mode-map
 181   (setq nngnorb-attachment-file-list
 182         ;; Copy the list of attached files from the nnir-tmp-buffer to
 183         ;; this summary buffer.
 184         (buffer-local-value
 185          'nngnorb-attachment-file-list
 186           (get-buffer-create nnir-tmp-buffer))))
 187
 188 (define-key gnorb-summary-minor-mode-map
 189   [remap gnus-summary-exit]
 190   'gnorb-summary-exit)
 191
 192 (define-key gnorb-summary-minor-mode-map (kbd "C-c d")
 193   'gnorb-summary-disassociate-message)
 194
 195 ;; All this is pretty horrible, but it's the only way to get sane
 196 ;; behavior, there are no appropriate hooks, and I want to avoid
 197 ;; advising functions.
 198
 199 (define-key gnorb-summary-minor-mode-map
 200   [remap gnus-summary-very-wide-reply-with-original]
 201   'gnorb-summary-very-wide-reply-with-original)
 202
 203 (define-key gnorb-summary-minor-mode-map
 204   [remap gnus-summary-wide-reply-with-original]
 205   'gnorb-summary-wide-reply-with-original)
 206
 207 (define-key gnorb-summary-minor-mode-map
 208   [remap gnus-summary-reply]
 209   'gnorb-summary-reply)
 210
 211 (define-key gnorb-summary-minor-mode-map
 212   [remap gnus-summary-very-wide-reply]
 213   'gnorb-summary-very-wide-reply)
 214
 215 (define-key gnorb-summary-minor-mode-map
 216   [remap gnus-summary-reply-with-original]
 217   'gnorb-summary-reply-with-original)
 218
 219 (define-key gnorb-summary-minor-mode-map
 220   [remap gnus-summary-wide-reply]
 221   'gnorb-summary-wide-reply)
 222
 223 (define-key gnorb-summary-minor-mode-map
 224   [remap gnus-summary-mail-forward]
 225   'gnorb-summary-mail-forward)
 226
 227 (defun gnorb-summary-wide-reply (&optional yank)
 228   (interactive
 229    (list (and current-prefix-arg
 230               (gnus-summary-work-articles 1))))
 231   (gnorb-summary-reply yank t))
 232
 233 (defun gnorb-summary-reply-with-original (n &optional wide)
 234   (interactive "P")
 235   (gnorb-summary-reply (gnus-summary-work-articles n) wide))
 236
 237 (defun gnorb-summary-very-wide-reply (&optional yank)
 238   (interactive
 239    (list (and current-prefix-arg
 240               (gnus-summary-work-articles 1))))
 241   (gnorb-summary-reply yank t (gnus-summary-work-articles yank)))
 242
 243 (defun gnorb-summary-reply (&optional yank wide very-wide)
 244   (interactive)
 245   (gnus-summary-reply yank wide very-wide)
 246   (gnorb-summary-reply-hook))
 247
 248 (defun gnorb-summary-wide-reply-with-original (n)
 249   (interactive "P")
 250   (gnorb-summary-reply-with-original n t))
 251
 252 (defun gnorb-summary-very-wide-reply-with-original (n)
 253   (interactive "P")
 254   (gnorb-summary-reply
 255    (gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
 256
 257 (defun gnorb-summary-mail-forward (n)
 258   (interactive "P")
 259   (gnus-summary-mail-forward n t)
 260   (gnorb-summary-reply-hook))
 261
 262 (defun gnorb-summary-reply-hook (&rest args)
 263   "Function that runs after any command that creates a reply."
 264   ;; Not actually a "hook"
 265   (let* ((msg-id (aref message-reply-headers 4))
 266          (org-id (car-safe (gnus-registry-get-id-key msg-id 'gnorb-ids)))
 267          (compose-marker (make-marker))
 268          (attachments (buffer-local-value
 269                        'nngnorb-attachment-file-list
 270                        (get-buffer nnir-tmp-buffer))))
 271     (when org-id
 272       (move-marker compose-marker (point))
 273       (save-restriction
 274         (widen)
 275         (message-narrow-to-headers-or-head)
 276         (goto-char (point-at-bol))
 277         (open-line 1)
 278         (message-insert-header
 279          (intern gnorb-mail-header)
 280          org-id)
 281         ;; As with elsewhere, this should be redundant with
 282         ;; `gnorb-gnus-check-outgoing-headers.'  Even if not, it
 283         ;; should be switched to use `message-send-actions'
 284         ;; (add-to-list 'message-exit-actions
 285         ;; 'gnorb-org-restore-after-send t)
 286         )
 287       (goto-char compose-marker))
 288     (when attachments
 289       (map-y-or-n-p
 290        (lambda (a) (format "Attach %s to outgoing message? "
 291                            (file-name-nondirectory a)))
 292        (lambda (a)
 293          (mml-attach-file a (mm-default-file-encoding a)
 294                           nil "attachment"))
 295        attachments
 296        '("file" "files" "attach")))))
 297
 298 (defun gnorb-summary-exit ()
 299   "Like `gnus-summary-exit', but restores the gnorb window conf."
 300   (interactive)
 301   (call-interactively 'gnus-summary-exit)
 302   (gnorb-restore-layout))
 303
 304 (defun gnorb-summary-disassociate-message ()
 305   "Disassociate a message from its Org TODO.
 306
 307 This is used in a Gnorb-created *Summary* buffer to remove the
 308 connection between the message and whichever Org TODO resulted in
 309 the message being included in this search."
 310   (interactive)
 311   (unless (get-buffer-window gnus-article-buffer t)
 312     (gnus-summary-display-article
 313      (gnus-summary-article-number)))
 314   (let* ((msg-id (gnus-fetch-original-field "message-id"))
 315          (org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids))
 316          chosen multiple-alist)
 317     (if org-ids
 318         (progn
 319           (if (= (length org-ids) 1)
 320               ;; Only one associated Org TODO.
 321               (progn (gnus-registry-set-id-key msg-id 'gnorb-ids nil)
 322                      (setq chosen (car org-ids)))
 323             ;; Multiple associated TODOs, prompt to choose one.
 324             (setq multiple-alist
 325                   (mapcar
 326                    (lambda (h)
 327                      (cons (gnorb-pretty-outline h) h))
 328                    org-ids))
 329             (setq chosen
 330                   (cdr
 331                    (assoc
 332                     (org-completing-read
 333                      "Choose a TODO to disassociate from: "
 334                      multiple-alist)
 335                     multiple-alist)))
 336             (gnus-registry-set-id-key msg-id 'gnorb-ids
 337                                       (remove chosen org-ids)))
 338           (message "Message disassociated from %s"
 339                    (gnorb-pretty-outline chosen)))
 340       (message "Message has no associations"))))
 341
 342 (defvar nngnorb-status-string "")
 343
 344 (defun nngnorb-retrieve-headers (articles &optional group server fetch-old)
 345   (with-current-buffer nntp-server-buffer
 346     (erase-buffer))
 347   'nov)
 348
 349 (defun nngnorb-open-server (server &optional definitions)
 350   t)
 351
 352 (defun nngnorb-close-server (&optional server)
 353   t)
 354
 355 (defun nngnorb-request-close ()
 356   t)
 357
 358 (defun nngnorb-server-opened (&optional server)
 359   t)
 360
 361 (defun nngnorb-status-message (&optional server)
 362   nngnorb-status-string)
 363
 364 (defun nngnorb-request-article (article &optional group server to-buffer)
 365   (setq nngnorb-status-string "No such group")
 366   nil)
 367
 368 (defun nngnorb-request-group (group &optional server fast info)
 369   (let (deactivate-mark)
 370     (with-current-buffer nntp-server-buffer
 371       (erase-buffer)
 372       (insert "411 no such news group\n")))
 373   (setq nngnorb-status-string "No such group")
 374   nil)
 375
 376 (defun nngnorb-close-group (group &optional server)
 377   t)
 378
 379 (defun nngnorb-request-list (&optional server)
 380   (with-current-buffer nntp-server-buffer
 381     (erase-buffer))
 382   t)
 383
 384 (defun nngnorb-request-post (&optional server)
 385   (setq nngnorb-status-string "Read-only server")
 386   nil)
 387
 388 (provide 'nngnorb)
 389
 390 ;;; nnnil.el ends here