Actually mention the STARTTLS upgrade.

[gnus] / lisp / proto-stream.el

diff --git a/lisp/proto-stream.el b/lisp/proto-stream.el
index c1acf4b..3cbbb98 100644 (file)
--- a/lisp/proto-stream.el
+++ b/lisp/proto-stream.el
@@ -40,6 +40,7 @@
 ;;  "*nnimap*" buffer address port
 ;;  :type 'network
 ;;  :capability-command "1 CAPABILITY\r\n"
+;;  :success " OK "
 ;;  :starttls-function
 ;;  (lambda (capabilities)
 ;;    (if (not (string-match "STARTTLS" capabilities))
@@ -65,7 +66,7 @@
 
 ;;;###autoload
 (defun open-protocol-stream (name buffer host service &rest parameters)
-  "Open a network stream to HOST.
+  "Open a network stream to HOST, upgrading to STARTTLS if possible.
 The first four parameters have the same meaning as in
 `open-network-stream'.  The function returns a list where the
 first element is the stream, the second element is the greeting
@@ -76,11 +77,16 @@ The PARAMETERS is a keyword list that can have the following
 values:
 
 :type -- either `network', `tls', `shell' or `starttls'.  If
-omitted, the default is `network'.
+omitted, the default is `network'.  `network' will be
+opportunistically upgraded to STARTTLS if both the server and
+Emacs supports it.
 
 :end-of-command -- a regexp saying what the end of a command is.
 This defaults to \"\\n\".
 
+:success -- a regexp saying whether the STARTTLS command was
+successful or not.  For instance, for NNTP this is \"^3\".
+
 :capability-command -- a string representing the command used to
 query server for capabilities.  For instance, for IMAP this is
 \"1 CAPABILITY\\r\\n\".
@@ -110,7 +116,8 @@ command to switch on STARTTLS otherwise."
         (capability-command (cadr (memq :capability-command parameters)))
         (eoc (proto-stream-eoc parameters))
         (type (cadr (memq :type parameters)))
-        (greeting (proto-stream-get-response stream start eoc)))
+        (greeting (proto-stream-get-response stream start eoc))
+        success)
     (if (not capability-command)
        (list stream greeting nil)
       (let* ((capabilities
@@ -119,25 +126,28 @@ command to switch on STARTTLS otherwise."
              (funcall (cadr (memq :starttls-function parameters))
                       capabilities)))
        (cond
-        ((or (not starttls-command)
-             (and (not (eq type 'starttls))
-                  (not proto-stream-always-use-starttls)))
          ;; If this server doesn't support STARTTLS, but we have
          ;; requested it explicitly, then close the connection and
          ;; return nil.
+        ((or (not starttls-command)
+             (and (not (eq type 'starttls))
+                  (not proto-stream-always-use-starttls)))
          (if (eq type 'starttls)
              (progn
                (delete-process stream)
                nil)
            ;; Otherwise, just return this plain network connection.
            (list stream greeting capabilities)))
+        ;; We have some kind of STARTTLS support, so we try to
+        ;; upgrade the connection opportunistically.
         ((or (fboundp 'open-gnutls-stream)
              (executable-find "gnutls-cli"))
          (unless (fboundp 'open-gnutls-stream)
            (delete-process stream)
+           (setq start (with-current-buffer buffer (point-max)))
            (let* ((starttls-use-gnutls t)
                   (starttls-extra-arguments
-                   (if (eq type 'starttls)
+                   (if (not (eq type 'starttls))
                        ;; When doing opportunistic TLS upgrades we
                        ;; don't really care about the identity of the
                        ;; peer.
@@ -145,26 +155,40 @@ command to switch on STARTTLS otherwise."
                      starttls-extra-arguments)))
              (setq stream (starttls-open-stream name buffer host service)))
            (proto-stream-get-response stream start eoc))
-         (proto-stream-command stream starttls-command eoc)
-         (if (fboundp 'open-gnutls-stream)
-             (gnutls-negotiate stream nil)
-           (unless (starttls-negotiate stream)
-             (delete-process stream)
-             (setq stream nil)))
-         (when (or (null stream)
-                   (not (memq (process-status stream)
-                              '(open run))))
-           ;; It didn't successfully negotiate STARTTLS, so we reopen
-           ;; the connection.
-           (setq stream (open-network-stream name buffer host service))
-           (proto-stream-get-response stream start eoc))
-         ;; Re-get the capabilities, since they may have changed
-         ;; after switching to TLS.
-         (list stream greeting
-               (proto-stream-command stream capability-command eoc)))
+         (if (not
+              (string-match
+               (cadr (memq :success parameters))
+               (proto-stream-command stream starttls-command eoc)))
+             ;; We got an error back from the STARTTLS command.
+             (progn
+               (if (eq type 'starttls)
+                   (progn
+                     (delete-process stream)
+                     nil)
+                 (list stream greeting capabilities)))
+           ;; The server said it was OK to start doing STARTTLS negotiations.
+           (if (fboundp 'open-gnutls-stream)
+               (gnutls-negotiate stream nil)
+             (unless (starttls-negotiate stream)
+               (delete-process stream)
+               (setq stream nil)))
+           (when (or (null stream)
+                     (not (memq (process-status stream)
+                                '(open run))))
+             ;; It didn't successfully negotiate STARTTLS, so we reopen
+             ;; the connection.
+             (setq stream (open-network-stream name buffer host service))
+             (proto-stream-get-response stream start eoc))
+           ;; Re-get the capabilities, since they may have changed
+           ;; after switching to TLS.
+           (list stream greeting
+                 (proto-stream-command stream capability-command eoc))))
+        ;; We don't have STARTTLS support available, but the caller
+        ;; requested a STARTTLS connection, so we give up.
         ((eq (cadr (memq :type parameters)) 'starttls)
          (delete-process stream)
          nil)
+        ;; Fall back on using a plain network stream.
         (t
          (list stream greeting capabilities)))))))