master 28fff38: Allow automatic X-Message-SMTP-Method header insertion

[Philip Kaludercic]

branch: master
commit 28fff38eeb9e7641937bc3448d43c0a7d0eb6bbc
Author: Philip Kaludercic <philipk@posteo.net>
Commit: Philip Kaludercic <philipk@posteo.net>

    Allow automatic X-Message-SMTP-Method header insertion
    
    * message.el (message-server-alist): Add user option
    (message-update-smtp-method-header): Add function
    (message-send): Call message-update-smtp-method-header
    * doc/misc/message.texi (Sending Variables): Document
    message-server-alist
    * etc/NEWS: Add news entry
---
 doc/misc/message.texi |  9 +++++++++
 etc/NEWS              |  5 +++++
 lisp/gnus/message.el  | 38 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 52 insertions(+)

diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index 4136ad8..dac5e75 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -2553,6 +2553,15 @@ if @code{nil} let the mailer mail back a message to 
report errors.
 When non-@code{nil}, Gnus will ask for confirmation when sending a
 message.
 
+@item message-server-alist
+@vindex message-server-alist
+An alist describing how to insert a @code{X-Message-SMTP-Method}
+header before sending out a new message.  The key has to be a string,
+that will be matched with the @code{From} header, and will insert the
+value as the SMTP Method if these are equal.  Alternatively, the key
+may be a function that will be called in the message buffer without
+any arguments, and matches if a non-nil value is returned.
+
 @end table
 
 
diff --git a/etc/NEWS b/etc/NEWS
index ff01ab7..86f1807 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -401,6 +401,11 @@ If non-nil, 'C-c C-a' will put attached files at the end 
of the message.
 ---
 *** Message Mode now supports image yanking.
 
+---
+*** New user option 'message-server-alist'
+Enables automatically inserting "X-Message-SMTP-Method" before sending
+a message.
+
 ** HTML Mode
 
 ---
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 285369b..8c88ac8 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -4335,6 +4335,43 @@ Instead, just auto-save the buffer and then bury it."
 
 (autoload 'mml-secure-bcc-is-safe "mml-sec")
 
+(defcustom message-server-alist nil
+  "Alist of rules to generate \"X-Message-SMTP-Method\" headers.
+If any entry of the form (COND . METHOD) matches, the header will
+be inserted just before the message is sent.  If COND is a
+string, METHOD will be inserted if the \"From\" header matches
+COND.  If COND is a function, METHOD will be inserted if COND
+returns a non-nil value, when called in the message buffer
+without any arguments.  If METHOD is nil in the last case, the
+return value of the function will be returned instead.  None of
+this applies if the buffer already has a\"X-Message-SMTP-Method\"
+header."
+  :type '(alist :key-type '(choice
+                            (string :tag "From Address")
+                            (function :tag "Predicate"))
+                :value-type 'string)
+  :version "29.1"
+  :group 'message-sending)
+
+(defun message-update-smtp-method-header ()
+  "Check `message-server-alist' to insert a SMTP-Method header."
+  (unless (message-fetch-field "X-Message-SMTP-Method")
+    (let ((from (mail-extract-address-components (message-fetch-field "From")))
+          method)
+      (catch 'exit
+        (dolist (server message-server-alist)
+          (cond ((functionp (car server))
+                 (let ((res (funcall (car server))))
+                   (when res
+                     (setq method (or (cdr server) res))
+                     (throw 'exit nil))))
+                ((and (stringp (car server))
+                      (string= (car server) from))
+                 (setq method (cdr server))
+                 (throw 'exit nil)))))
+      (when method
+        (message-add-header (concat "X-Message-SMTP-Method: " method))))))
+
 (defun message-send (&optional arg)
   "Send the message in the current buffer.
 If `message-interactive' is non-nil, wait for success indication or
@@ -4348,6 +4385,7 @@ It should typically alter the sending method in some way 
or other."
   (undo-boundary)
   (let ((inhibit-read-only t))
     (put-text-property (point-min) (point-max) 'read-only nil))
+  (message-update-smtp-method-header)
   (message-fix-before-sending)
   (run-hooks 'message-send-hook)
   (mml-secure-bcc-is-safe)