Allow open-network-stream to use different TLS capability commands

* doc/lispref/processes.texi (Network): Document non-string
capability command.
* lisp/gnus/nntp.el (nntp-open-connection): Use HELP for Typhoon
and CAPABILITIES for everything else (bug#41960).

* lisp/net/network-stream.el (open-network-stream): Document
function variety of :capability-command.
(network-stream-open-starttls): Use it.
(network-stream-open-tls): Ditto.
(network-stream-open-shell): Ditto.
(network-stream--capability-command): New helper function.

diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 22c509361851fc6f6d020aa4e455815ea30cc0fa..4002004cd6f65a00f23830f167eff41c8d4c6bc8 100644 (file)
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -2511,7 +2511,10 @@ If non-@code{nil}, always ask for the server's capabilities, even when
 doing a @samp{plain} connection.
 
 @item :capability-command @var{capability-command}
-Command string to query the host capabilities.
+Command to query the host capabilities.  This can either be a string
+(which will then be sent verbatim to the server), or a function
+(called with a single parameter; the "greeting" from the server when
+connecting), and should return a string.
 
 @item :end-of-command @var{regexp}
 @itemx :end-of-capability @var{regexp}

diff --git a/etc/NEWS b/etc/NEWS
index 7e6be008614972d3ec1f2a80a9e593eea379042e..7fbe63013e887d5f5bd5efd0dd0df7c4cec81fa2 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -686,6 +686,12 @@ This allows specifying the coding systems used by a network process
 for encoding and decoding without having to bind
 'coding-system-for-{read,write}' or call 'set-process-coding-system'.
 
++++
+** 'open-network-stream' can now take a :capability-command that's a function.
+The function is called with the greeting from the server as its only
+parameter, and allows sending different TLS capability commands to the
+server based on that greeting.
+
 +++
 ** 'open-gnutls-stream' now also accepts a ':coding' argument.
 

diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 02d90603b4031469edaf75a6d932d92135748717..a5c824479269856944e3b0502193a35b84a1f635 100644 (file)
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1263,7 +1263,17 @@ If SEND-IF-FORCE, only send authinfo to the server if the
                     "nntpd" pbuffer nntp-address nntp-port-number
                     :type (cadr (assoc nntp-open-connection-function map))
                     :end-of-command "^\\([2345]\\|[.]\\).*\n"
-                    :capability-command "HELP\r\n"
+                    :capability-command
+                    (lambda (greeting)
+                      (if (and greeting
+                               (string-match "Typhoon" greeting))
+                          ;; Certain versions of the Typhoon server
+                          ;; doesn't understand the CAPABILITIES
+                          ;; command, but includes the capability
+                          ;; data in the HELP command instead.
+                          "HELP\r\n"
+                        ;; Use the correct command for everything else.
+                        "CAPABILITIES\r\n"))
                     :success "^3"
                     :starttls-function
                     (lambda (capabilities)

diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 1c371f598706e4d4f1798a52e609019e15ea33dc..e86426d466477515e9f810d5ee673960de83510b 100644 (file)
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -139,7 +139,10 @@ writes.  See `make-network-process' for details.
 
 :capability-command specifies a command used to query the HOST
   for its capabilities.  For instance, for IMAP this should be
-  \"1 CAPABILITY\\r\\n\".
+  \"1 CAPABILITY\\r\\n\".  This can either be a string (which will
+  then be sent verbatim to the server), or a function (called with
+  a single parameter; the \"greeting\" from the server when connecting),
+  and should return a string to send to the server.
 
 :starttls-function specifies a function for handling STARTTLS.
   This function should take one parameter, the response to the
@@ -280,8 +283,11 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
                                        :coding (plist-get parameters :coding)))
         (greeting (and (not (plist-get parameters :nogreeting))
                        (network-stream-get-response stream start eoc)))
-        (capabilities (network-stream-command stream capability-command
-                                              eo-capa))
+        (capabilities
+          (network-stream-command
+           stream
+           (network-stream--capability-command capability-command greeting)
+           eo-capa))
         (resulting-type 'plain)
         starttls-available starttls-command error)
 
@@ -329,7 +335,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
        ;; Requery capabilities for protocols that require it; i.e.,
        ;; EHLO for SMTP.
        (when (plist-get parameters :always-query-capabilities)
-         (network-stream-command stream capability-command eo-capa)))
+         (network-stream-command
+           stream
+           (network-stream--capability-command capability-command greeting)
+           eo-capa)))
       (when (let ((response
                   (network-stream-command stream starttls-command eoc)))
              (and response (string-match success-string response)))
@@ -365,7 +374,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
                  host service))
        ;; Re-get the capabilities, which may have now changed.
        (setq capabilities
-             (network-stream-command stream capability-command eo-capa))))
+             (network-stream-command
+               stream
+               (network-stream--capability-command capability-command greeting)
+               eo-capa))))
 
     ;; If TLS is mandatory, close the connection if it's unencrypted.
     (when (and require-tls
@@ -428,7 +440,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
                                     parameters)
               (require 'tls)
               (open-tls-stream name buffer host service)))
-          (eoc (plist-get parameters :end-of-command)))
+          (eoc (plist-get parameters :end-of-command))
+           greeting)
       (if (plist-get parameters :nowait)
           (list stream nil nil 'tls)
         ;; Check certificate validity etc.
@@ -440,17 +453,22 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
           ;; openssl/gnutls-cli.
           (when (and (not (gnutls-available-p))
                      eoc)
-            (network-stream-get-response stream start eoc)
+            (setq greeting (network-stream-get-response stream start eoc))
             (goto-char (point-min))
             (when (re-search-forward eoc nil t)
               (goto-char (match-beginning 0))
               (delete-region (point-min) (line-beginning-position))))
-          (let ((capability-command (plist-get parameters :capability-command))
+          (let ((capability-command
+                 (plist-get parameters :capability-command))
                 (eo-capa (or (plist-get parameters :end-of-capability)
                              eoc)))
             (list stream
                   (network-stream-get-response stream start eoc)
-                  (network-stream-command stream capability-command eo-capa)
+                  (network-stream-command
+                   stream
+                   (network-stream--capability-command
+                    capability-command greeting)
+                   eo-capa)
                   'tls)))))))
 
 (defun network-stream-open-shell (name buffer host service parameters)
@@ -464,21 +482,29 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
                                  (format-spec
                                   (plist-get parameters :shell-command)
                                    `((?s . ,host)
-                                     (?p . ,service)))))))
+                                     (?p . ,service))))))
+         greeting)
     (when coding (if (consp coding)
-                       (set-process-coding-system stream
-                                                  (car coding)
-                                                  (cdr coding))
                      (set-process-coding-system stream
-                                                coding
-                                                coding)))
+                                                (car coding)
+                                                (cdr coding))
+                   (set-process-coding-system stream
+                                              coding
+                                              coding)))
     (list stream
-         (network-stream-get-response stream start eoc)
-         (network-stream-command stream capability-command
-                                 (or (plist-get parameters :end-of-capability)
-                                     eoc))
+         (setq greeting (network-stream-get-response stream start eoc))
+         (network-stream-command
+           stream
+           (network-stream--capability-command capability-command greeting)
+          (or (plist-get parameters :end-of-capability)
+              eoc))
          'plain)))
 
+(defun network-stream--capability-command (command greeting)
+  (if (functionp command)
+      (funcall command greeting)
+    command))
+
 (provide 'network-stream)
 
 ;;; network-stream.el ends here