[profile] / dot / gnus.el

;;; -*- mode: emacs-lisp; coding: utf-8 -*-
;;;
;;; GNUS configuration
;;;
;;; (c) 2009 Mark Wooding
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA

;;;--------------------------------------------------------------------------
;;; General Gnus preferences.

;; Divide the main groups list by topics.
(add-hook 'gnus-group-mode-hook 'gnus-topic-mode)
(setq gnus-subscribe-newsgroup-method 'gnus-subscribe-topics)

;; Use hacky movemail program to move mail.
(setq mail-source-movemail-program "~/bin/movemail-hack")

;; Don't force use of a full window.
(setq gnus-use-full-window nil)

;; Display a slrn-like tree view in the summary window.
(setq gnus-use-trees nil)
(setq gnus-summary-make-false-root 'dummy)
(setq gnus-summary-line-format
        "%U%R%z%4L %(%[%-16,16f%]%): %B %s\n"
      gnus-summary-dummy-line-format
        "        %(%[----------------%]%): * %S\n")
(setq gnus-sum-thread-tree-root ">"
      gnus-sum-thread-tree-false-root ">"
      gnus-sum-thread-tree-single-indent "="
      gnus-sum-thread-tree-indent "  ")
(if (memq (coding-system-get (terminal-coding-system) 'mime-charset)
          '(nil utf-8))
    (setq gnus-sum-thread-tree-leaf-with-other "├─>"
          gnus-sum-thread-tree-vertical        "│ "
          gnus-sum-thread-tree-single-leaf     "╰─>")
  (setq gnus-sum-thread-tree-leaf-with-other   "|->"
        gnus-sum-thread-tree-vertical          "| "
        gnus-sum-thread-tree-single-leaf       "`->"))

;; Sort threads in a useful way.
(setq gnus-thread-sort-functions
        '(gnus-thread-sort-by-number
          gnus-thread-sort-by-subject
          gnus-thread-sort-by-total-score))

;; Configure the crypto.
(setq mm-verify-option 'known
      mm-sign-option 'guided
      mm-decrypt-option 'never)

;; Tracking available groups.  These should work for sane servers, but maybe
;; they'll need hacking in the local file.
(setq gnus-save-killed-list nil
      gnus-check-bogus-newsgroups nil
      gnus-read-active-file 'ask-server)

;; Don't skip unread groups.
(setq gnus-group-goto-unread nil
      gnus-summary-next-group-on-exit nil)

;; Use one article buffer per group.
(setq gnus-single-article-buffer nil)

;; Don't expand threads on initial opening.
(setq gnus-thread-hide-subtree t)

;; Don't use strange icons instead of traditional smileys.
(setq gnus-treat-display-smileys nil)

;; Fairly large numbers of articles are OK; don't bother warning me.
(setq gnus-large-newsgroup 500)

;; When splitting articles, crossposting is a reasonable thing to do.
(setq nnimap-split-crosspost t)

;; We may have the misfortune to talk to an Exchange server.
(setq imap-enable-exchange-bug-workaround t)

;; Save articles in mbox format by default, of course, and save an entire
;; batch with the same name.
(setq gnus-prompt-before-saving t
      gnus-default-article-saver 'gnus-summary-save-in-mail)

;; Clean up properly when closing the summary.
(defadvice gnus-summary-exit (before mdw-kill-debris compile activate)
  (gnus-summary-expand-window))

;; Configure article display a bit.
(defun mdw-gnus-article-setup ()
  (setq truncate-lines nil
        truncate-partial-width-windows nil
        word-wrap t
        wrap-prefix (concat (propertize "..." 'face 'mdw-ellipsis-face)
                            " ")))
(add-hook 'gnus-article-mode-hook #'mdw-gnus-article-setup)

;; Don't expire articles on selection if they're alread read.  This provides
;; a handy way to prevent expiry, and actually forcing expiry isn't
;; significantly harder.
(remove-hook 'gnus-mark-article-hook
             'gnus-summary-mark-read-and-unread-as-read)
(add-hook 'gnus-mark-article-hook 'gnus-summary-mark-unread-as-read)

;; Leave an oubliette level 7 for broken things which look like mailboxes.
;; Otherwise Gnus keeps on resurrecting them and later realising that they're
;; bogus.
(setq gnus-level-unsubscribed 6)

;; Reconfigure the `nnmail-split-fancy' syntax table to be less mad.
(setq nnmail-split-fancy-syntax-table
      (let ((table (make-syntax-table)))

        ;; This is from upstream.  I don't know what it's for.
        (modify-syntax-entry ?% "." table)

        ;; Email addresses are often wrapped in `<...>', so don't consider
        ;; those to be part of the address.
        (modify-syntax-entry ?< "(>" table)
        (modify-syntax-entry ?> ")<" table)

        ;; Email addresses definitely contain `.'.
        (modify-syntax-entry ?. "_" table)

        ;; Done.
        table))

;;;--------------------------------------------------------------------------
;;; Magic for sending mail the correct way.

(defvar mdw-send-mail-alist nil
  "An alist containing ways of sending email.
The keys are symbols naming mail-sending methods.  The values are
alists mapping Lisp variable names to values which will be bound
around a call to the underlying `send-mail-function'.  See
`mdw-message-send-it'.")

(defvar mdw-guess-send-mail-alist nil
  "An alist for guessing the right way to send mail from a `From' address.
The keys are (Emacs-style) regular expressions.  The values are
strings naming mail-sending methods, to be used if there is no
`mdw-send-mail-header-name' mail header.")

(defvar mdw-send-mail-header-name "X-mdw-Send-Mail"
  "Mail header used to override the mail-sending method.
If a header with this name exists, then `mdw-message-send-it'
will look its value up in `mdw-send-mail-alist' to find out how
to send the message.  The idea is that you can set this header
from `gnus-posting-styles'.  The header will be stripped on
sending.")

(defvar mdw-default-send-mail-method nil
  "The name of the default mail-sending method.")

(defun mdw-message-send-it ()
  "Send mail using the appropriate mail sending method.
Firstly, a mail-sending method name is determined.  If
`mdw-send-mail-header-name' has a non-nil value, and a header
with this name exists in the message being sent, then its value
is used as the name.  Otherwise, the email address from the
`From' header is matched against the named of the association in
`mdw-guess-send-mail-alist', and if any of them match then the
corresponding value is used as the name.  Otherwise, the value of
`mdw-default-send-mail-method' is used.

The name is then looked up in `mdw-send-mail-alist' to find an
alist of temporary variable bindings; an error is reported if no
matching entry is found.  The variables are temporarily bound to
their corresponding values, and the (possibly freshly rebound)
`send-mail-function' is invoked with no parameters.

If the method name is `nil', then `send-mail-function' is simply
invoked without doing anything else very special.  This can
therefore be left as a useful default, if it's generally the
right thing."

  (let* ((method-name
          (or

           ;; Firstly, if there's an explicit header in the message, then
           ;; we'd better use that.
           (let ((method (message-fetch-field mdw-send-mail-header-name)))
             (and method (intern method)))

           ;; Look up the sender's address in the guess list.
           (let* ((sender (some #'message-fetch-field
                                '("resent-sender" "resent-from"
                                  "sender" "from")))
                  (addr (cadr (mail-extract-address-components sender)))
                  (alist mdw-guess-send-mail-alist)
                  assoc)
             (catch 'found
               (while alist
                 (setq assoc (pop alist))
                 (when (string-match (car assoc) addr)
                   (throw 'found (cdr assoc))))
               nil))

           ;; Otherwise use the default.
           mdw-default-send-mail-method))

         (method (and method-name
                      (let ((assoc (assq method-name mdw-send-mail-alist)))
                        (if assoc (cdr assoc)
                          (error "Unknown send-mail method `%s'."
                                 method-name))))))

    ;; Bind the appropriate variables.
    (progv
        (mapcar #'car method)
        (mapcar #'cdr method)

      ;; Make a copy of the buffer and strip out our magic header.  (If the
      ;; message send fails, it would be annoying to have lost the magic
      ;; token which tells us how to retry properly.)
      (let ((buf (current-buffer)))
        (with-temp-buffer
          (insert-buffer buf)
          (message-remove-header mdw-send-mail-header-name)
          (funcall send-mail-function))))))

(setq message-send-mail-function 'mdw-message-send-it)

;;;--------------------------------------------------------------------------
;;; Local configuration.

;; Fetching news from the local news server seems sensible.
(setq gnus-select-method
      (let ((server (mdw-config 'nntp-server)))
        (if server
            `(nntp ,server)
          '(nnnil ""))))

;; Now load a local configuration file.
(load "~/.gnus-local.el")

;;;----- That's all, folks --------------------------------------------------