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