From: Mark Wooding Date: Tue, 15 Dec 2015 19:15:23 +0000 (+0000) Subject: dot/gnus.el, dot/gnus-local.el.distorted: Fancy mail sending. X-Git-Url: https://git.distorted.org.uk/~mdw/profile/commitdiff_plain/24da418485641fe2bb7be447ccbc858a9d789aac?ds=sidebyside 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 15c76e2..466296c 100644 --- a/dot/gnus-local.el.distorted +++ b/dot/gnus-local.el.distorted @@ -8,14 +8,34 @@ ;;;-------------------------------------------------------------------------- ;;; 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. @@ -82,7 +102,12 @@ '(("^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 diff --git a/dot/gnus.el b/dot/gnus.el index 91d5d81..2aa71d3 100644 --- a/dot/gnus.el +++ b/dot/gnus.el @@ -104,6 +104,102 @@ (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. ;; Fetching news from the local news server seems sensible.