dot/gnus.el, dot/gnus-local.el.distorted: Fancy mail sending.

This configuration can now send mail to different servers based on a
variety of criteria.

diff --git a/dot/gnus-local.el.distorted b/dot/gnus-local.el.distorted
index 15c76e2ee9cc0954a2db9632833ca6043dde2910..466296ce85aa7d16249d13d6449a7f4e9da681bb 100644 (file)
--- a/dot/gnus-local.el.distorted
+++ b/dot/gnus-local.el.distorted
@@ -8,14 +8,34 @@
 ;;;--------------------------------------------------------------------------
 ;;; How to send mail.
 
 ;;;--------------------------------------------------------------------------
 ;;; How to send mail.
 

-(and nil
-     (setq smtpmail-smtp-server "mail.distorted.org.uk"
-          smtpmail-sendto-domain "distorted.org.uk"
-          smtpmail-smtp-service 587
-          smtpmail-auth-credentials "~/.gnus.authinfo"
-          message-send-mail-function 'smtpmail-send-it
-          smtpmail-starttls-credentials
-          '(("mail.distorted.org.uk" 587 "" ""))))
+(setq smtpmail-smtp-service 587
+      smtpmail-auth-credentials "~/.gnus.authinfo")
+
+(setq mdw-send-mail-alist
+      `((distorted-smtp
+        (send-mail-function . smtpmail-send-it)
+        (smtpmail-smtp-server . "mail.distorted.org.uk")
+        (smtpmail-starttls-credentials
+         ("mail.distorted.org.uk" 587 nil nil)))
+       (chiark-smtp
+        (send-mail-function . smtpmail-send-it)
+        (smtpmail-smtp-server . "smtp.dovecot.chiark.greenend.org.uk")
+        (starttls-extra-arguments "--insecure")
+        (smtpmail-starttls-credentials
+         ("smtp.dovecot.chiark.greenend.org.uk" 587 nil nil)))
+       (gmail-smtp
+        (send-mail-function . smtpmail-send-it)
+        (smtpmail-smtp-server . "smtp.gmail.com")
+        (smtpmail-starttls-credentials
+         ("smtp.gmail.com" 587 nil nil))))
+      mdw-guess-send-mail-alist
+      `((,(concat "@\\(" "\\(chiark\\|slimy\\|coriolis\\)"
+                        "\\.greenend\\.org\\.uk"
+                 "\\|"  "evade\\.org\\.uk"
+                 "\\|"  "fyvzl\\.net"
+                 "\\)$") . chiark-smtp)
+       ("@g\\(\\|oogle\\)mail\\.com$" . gmail-smtp))
+      mdw-default-send-mail-method nil)

 
 ;;;--------------------------------------------------------------------------
 ;;; News via chiark.
 
 ;;;--------------------------------------------------------------------------
 ;;; News via chiark.


@@ -82,7 +102,12 @@
       '(("^nnimap\\+distorted:crap\\."
         (address (concat "mdw-nospam-"
                          (substring gnus-newsgroup-name (match-end 0))
       '(("^nnimap\\+distorted:crap\\."
         (address (concat "mdw-nospam-"
                          (substring gnus-newsgroup-name (match-end 0))

-                         "@distorted.org.uk")))))
+                         "@distorted.org.uk")))
+       ("^nnimap\\+[^:]+-chiark:"
+        ("X-mdw-Send-Mail" "chiark-smtp"))
+       ("^nnimap\\+google:"
+        (address "distorted.mdw@gmail.com")
+        ("X-mdw-Send-Mail" "gmail-smtp"))))

 
 ;; The actual splitting rules.
 (setq nnmail-split-fancy
 
 ;; The actual splitting rules.
 (setq nnmail-split-fancy

diff --git a/dot/gnus.el b/dot/gnus.el
index 91d5d8162df12d2c62c0217f5f8ade9a833a9c7b..2aa71d334aa06f9a6a45749cf78c68bf516db57e 100644 (file)
--- a/dot/gnus.el
+++ b/dot/gnus.el
@@ -103,6 +103,102 @@ (defun mdw-gnus-article-setup ()
                            " ")))
 (add-hook 'gnus-article-mode-hook #'mdw-gnus-article-setup)
 
                            " ")))
 (add-hook 'gnus-article-mode-hook #'mdw-gnus-article-setup)
 

+;;;--------------------------------------------------------------------------
+;;; 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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Local configuration.