master 0f7fc5cfdf9 20/37: Be smarter about switching to TLS from M-x erc

[F. Jason Park]

branch: master
commit 0f7fc5cfdf97a8280ea8f012e50af9e615e8c6ef
Author: F. Jason Park <jp@neverwas.me>
Commit: F. Jason Park <jp@neverwas.me>

    Be smarter about switching to TLS from M-x erc
    
    * lisp/erc/erc.el (erc--warn-unencrypted): Remove unused internal
    function.
    (erc-select-read-args): Offer to use TLS when user runs M-x erc and
    opts for default server and port or provides the well-known IANA TLS
    port or enters an ircs:// URL at the server prompt.  For the last two,
    do this immediately instead of calling `erc-tls' interactively and
    imposing a review of just-chosen values.  Also remove error warnings
    and ensure `erc-tls' still works by setting
    `erc-server-connect-function' to `erc-open-tls-stream' when
    appropriate.  Include the word "URL" in server prompt.
    (erc--with-entrypoint-environment): Add new macro for empowering an
    entry point's interactive form to bind special variables in their
    command's body without shadowing them in the lambda list.
    (erc, erc-tls): Add internal keyword argument for interactive use, but
    don't make it `keywordp' or advertise its presence.  Also use new
    helper macro, `erc--with-entrypoint-environment', to temporarily bind
    special vars given by interactive helper `erc-select-read-args'.
    * test/lisp/erc/erc-tests.el (erc--with-entrypoint-environment): Add
    new test.
    (erc-select-read-args): Modify return values to expect additional
    internal keyword argument where appropriate.
    (erc-tls): Make assertions about environment.
    (erc--interactive): New test.  (Bug#60428.)
---
 lisp/erc/erc.el            |  79 +++++++++++++---------
 test/lisp/erc/erc-tests.el | 159 ++++++++++++++++++++++++++++++++++++++-------
 2 files changed, 184 insertions(+), 54 deletions(-)

diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index ea581c17661..e1abfee9ba3 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2241,29 +2241,12 @@ parameters SERVER and NICK."
     (setq input (concat "irc://" input)))
   input)
 
-;; A temporary means of addressing the problem of ERC's namesake entry
-;; point defaulting to a non-TLS connection with its default server
-;; (bug#60428).
-(defun erc--warn-unencrypted ()
-  ;; Remove unconditionally to avoid wrong context due to races from
-  ;; simultaneous dialing or aborting (e.g., via `keybaord-quit').
-  (remove-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted)
-  (when (and (process-contact erc-server-process :nowait)
-             (equal erc-session-server erc-default-server)
-             (eql erc-session-port erc-default-port))
-    ;; FIXME use the autoloaded `info' instead of `Info-goto-node' in
-    ;; `erc-button-alist'.
-    (require 'info nil t)
-    (erc-display-error-notice
-     nil (concat "This connection is unencrypted.  Please use `erc-tls'"
-                 " from now on.  See Info:\"(erc) connecting\" for more."))))
-
 ;;;###autoload
 (defun erc-select-read-args ()
   "Prompt the user for values of nick, server, port, and password."
   (require 'url-parse)
   (let* ((input (let ((d (erc-compute-server)))
-                  (read-string (format "Server (default is %S): " d)
+                  (read-string (format "Server or URL (default is %S): " d)
                                nil 'erc-server-history-list d)))
          ;; For legacy reasons, also accept a URL without a scheme.
          (url (url-generic-parse-url (erc--ensure-url input)))
@@ -2286,15 +2269,32 @@ parameters SERVER and NICK."
                         (m (if p
                                (format "Server password (default is %S): " p)
                              "Server password (optional): ")))
-                   (if erc-prompt-for-password (read-passwd m nil p) p))))
+                   (if erc-prompt-for-password (read-passwd m nil p) p)))
+         (opener (and (or sp (eql port erc-default-port-tls)
+                          (and (equal server erc-default-server)
+                               (not (string-prefix-p "irc://" input))
+                               (eql port erc-default-port)
+                               (y-or-n-p "Connect using TLS instead? ")
+                               (setq port erc-default-port-tls)))
+                      #'erc-open-tls-stream))
+         env)
+    (when opener
+      (push `(erc-server-connect-function . ,opener) env))
     (when (and passwd (string= "" passwd))
       (setq passwd nil))
-    (when (and (equal server erc-default-server)
-               (eql port erc-default-port)
-               (not (eql port erc-default-port-tls)) ; not `erc-tls'
-               (not (string-prefix-p "irc://" input))) ; not yanked URL
-      (add-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted))
-    (list :server server :port port :nick nick :password passwd)))
+    `( :server ,server :port ,port :nick ,nick
+       ,@(and passwd `(:password ,passwd))
+       ,@(and env `(&interactive-env ,env)))))
+
+(defmacro erc--with-entrypoint-environment (env &rest body)
+  "Run BODY with bindings from ENV alist."
+  (declare (indent 1))
+  (let ((syms (make-symbol "syms"))
+        (vals (make-symbol "vals")))
+    `(let (,syms ,vals)
+       (pcase-dolist (`(,k . ,v) ,env) (push k ,syms) (push v ,vals))
+       (cl-progv ,syms ,vals
+         ,@body))))
 
 ;;;###autoload
 (cl-defun erc (&key (server (erc-compute-server))
@@ -2303,7 +2303,9 @@ parameters SERVER and NICK."
                     (user   (erc-compute-user))
                     password
                     (full-name (erc-compute-full-name))
-                    id)
+                    id
+                    ;; Used by interactive form
+                    ((&interactive-env --interactive-env--)))
   "ERC is a powerful, modular, and extensible IRC client.
 This function is the main entry point for ERC.
 
@@ -2326,9 +2328,12 @@ then the server and full-name will be set to those 
values,
 whereas `erc-compute-port' and `erc-compute-nick' will be invoked
 for the values of the other parameters.
 
-See `erc-tls' for the meaning of ID."
+See `erc-tls' for the meaning of ID.
+
+\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)"
   (interactive (erc-select-read-args))
-  (erc-open server port nick full-name t password nil nil nil nil user id))
+  (erc--with-entrypoint-environment --interactive-env--
+    (erc-open server port nick full-name t password nil nil nil nil user id)))
 
 ;;;###autoload
 (defalias 'erc-select #'erc)
@@ -2342,7 +2347,9 @@ See `erc-tls' for the meaning of ID."
                         password
                         (full-name (erc-compute-full-name))
                         client-certificate
-                        id)
+                        id
+                        ;; Used by interactive form
+                        ((&interactive-env --interactive-env--)))
   "ERC is a powerful, modular, and extensible IRC client.
 This function is the main entry point for ERC over TLS.
 
@@ -2386,10 +2393,20 @@ When present, ID should be a symbol or a string to use 
for naming
 the server buffer and identifying the connection unequivocally.
 See Info node `(erc) Network Identifier' for details.  Like USER
 and CLIENT-CERTIFICATE, this parameter cannot be specified
-interactively."
+interactively.
+
+\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)"
   (interactive (let ((erc-default-port erc-default-port-tls))
                 (erc-select-read-args)))
-  (let ((erc-server-connect-function 'erc-open-tls-stream))
+  ;; Bind `erc-server-connect-function' to `erc-open-tls-stream'
+  ;; around `erc-open' when a non-default value hasn't been specified
+  ;; by the user or the interactive form.  And don't bother checking
+  ;; for advice, indirect functions, autoloads, etc.
+  (unless (or (assq 'erc-server-connect-function --interactive-env--)
+              (not (eq erc-server-connect-function #'erc-open-network-stream)))
+    (push '(erc-server-connect-function . erc-open-tls-stream)
+          --interactive-env--))
+  (erc--with-entrypoint-environment --interactive-env--
     (erc-open server port nick full-name t password
               nil nil nil client-certificate user id)))
 
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index ae19b7d0aad..c5905ab4f67 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1064,32 +1064,62 @@
     (should (string-match erc--server-connect-dumb-ipv6-regexp
                           (concat "[" a "]")))))
 
+(ert-deftest erc--with-entrypoint-environment ()
+  (let ((env '((erc-join-buffer . foo)
+               (erc-server-connect-function . bar))))
+    (erc--with-entrypoint-environment env
+      (should (eq erc-join-buffer 'foo))
+      (should (eq erc-server-connect-function 'bar)))))
+
 (ert-deftest erc-select-read-args ()
 
-  (ert-info ("Does not default to TLS")
-    (should (equal (ert-simulate-keys "\r\r\r\r"
+  (ert-info ("Prompts for switch to TLS by default")
+    (should (equal (ert-simulate-keys "\r\r\r\ry\r"
                      (erc-select-read-args))
                    (list :server "irc.libera.chat"
-                         :port 6667
+                         :port 6697
+                         :nick (user-login-name)
+                         '&interactive-env '((erc-server-connect-function
+                                              . erc-open-tls-stream))))))
+
+  (ert-info ("Switches to TLS when port matches default TLS port")
+    (should (equal (ert-simulate-keys "irc.gnu.org\r6697\r\r\r"
+                     (erc-select-read-args))
+                   (list :server "irc.gnu.org"
+                         :port 6697
+                         :nick (user-login-name)
+                         '&interactive-env '((erc-server-connect-function
+                                              . erc-open-tls-stream))))))
+
+  (ert-info ("Switches to TLS when URL is ircs://")
+    (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r"
+                     (erc-select-read-args))
+                   (list :server "irc.gnu.org"
+                         :port 6697
                          :nick (user-login-name)
-                         :password nil))))
+                         '&interactive-env '((erc-server-connect-function
+                                              . erc-open-tls-stream))))))
+
+  (ert-info ("Opt out of non-TLS warning manually")
+    (should (equal (ert-simulate-keys "\r\r\r\rn\r"
+                     (erc-select-read-args))
+                   (list :server "irc.libera.chat"
+                         :port 6667
+                         :nick (user-login-name)))))
 
   (ert-info ("Override default TLS")
     (should (equal (ert-simulate-keys "irc://irc.libera.chat\r\r\r\r"
                      (erc-select-read-args))
                    (list :server "irc.libera.chat"
                          :port 6667
-                         :nick (user-login-name)
-                         :password nil))))
+                         :nick (user-login-name)))))
 
   (ert-info ("Address includes port")
-    (should (equal (ert-simulate-keys
-                       "localhost:6667\rnick\r\r"
+    (should (equal (ert-simulate-keys "localhost:6667\rnick\r\r"
                      (erc-select-read-args))
                    (list :server "localhost"
                          :port 6667
-                         :nick "nick"
-                         :password nil))))
+                         :nick "nick"))))
 
   (ert-info ("Address includes nick, password skipped via option")
     (should (equal (ert-simulate-keys "nick@localhost:6667\r"
@@ -1097,8 +1127,7 @@
                        (erc-select-read-args)))
                    (list :server "localhost"
                          :port 6667
-                         :nick "nick"
-                         :password nil))))
+                         :nick "nick"))))
 
   (ert-info ("Address includes nick and password")
     (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r"
@@ -1113,37 +1142,40 @@
                      (erc-select-read-args))
                    (list :server "[::1]"
                          :port 6667
-                         :nick (user-login-name)
-                         :password nil))))
+                         :nick (user-login-name)))))
 
   (ert-info ("IPv6 address with port")
     (should (equal (ert-simulate-keys "[::1]:6667\r\r\r"
                      (erc-select-read-args))
                    (list :server "[::1]"
                          :port 6667
-                         :nick (user-login-name)
-                         :password nil))))
+                         :nick (user-login-name)))))
 
   (ert-info ("IPv6 address includes nick")
     (should (equal (ert-simulate-keys "nick@[::1]:6667\r\r"
                      (erc-select-read-args))
                    (list :server "[::1]"
                          :port 6667
-                         :nick "nick"
-                         :password nil)))))
+                         :nick "nick")))))
 
 (ert-deftest erc-tls ()
-  (let (calls)
+  (let (calls env)
     (cl-letf (((symbol-function 'user-login-name)
                (lambda (&optional _) "tester"))
               ((symbol-function 'erc-open)
-               (lambda (&rest r) (push r calls))))
+               (lambda (&rest r)
+                 (push `((erc-server-connect-function
+                          ,erc-server-connect-function))
+                       env)
+                 (push r calls))))
 
       (ert-info ("Defaults")
         (erc-tls)
         (should (equal (pop calls)
                        '("irc.libera.chat" 6697 "tester" "unknown" t
-                         nil nil nil nil nil "user" nil))))
+                         nil nil nil nil nil "user" nil)))
+        (should (equal (pop env)
+                       '((erc-server-connect-function erc-open-tls-stream)))))
 
       (ert-info ("Full")
         (erc-tls :server "irc.gnu.org"
@@ -1156,7 +1188,9 @@
                  :id 'GNU.org)
         (should (equal (pop calls)
                        '("irc.gnu.org" 7000 "bob" "Bob's Name" t
-                         "bob:changeme" nil nil nil t "bobo" GNU.org))))
+                         "bob:changeme" nil nil nil t "bobo" GNU.org)))
+        (should (equal (pop env)
+                       '((erc-server-connect-function erc-open-tls-stream)))))
 
       ;; Values are often nil when called by lisp code, which leads to
       ;; null params.  This is why `erc-open' recomputes almost
@@ -1172,7 +1206,86 @@
                    :password "bob:changeme"))
         (should (equal (pop calls)
                        '(nil 7000 nil "Bob's Name" t
-                             "bob:changeme" nil nil nil nil "bobo" nil)))))))
+                             "bob:changeme" nil nil nil nil "bobo" nil)))
+        (should (equal (pop env)
+                       '((erc-server-connect-function erc-open-tls-stream)))))
+
+      (ert-info ("Interactive")
+        (ert-simulate-keys "nick:sesame@localhost:6667\r\r"
+          (call-interactively #'erc-tls))
+        (should (equal (pop calls)
+                       '("localhost" 6667 "nick" "unknown" t "sesame"
+                         nil nil nil nil "user" nil)))
+        (should (equal (pop env)
+                       '((erc-server-connect-function
+                          erc-open-tls-stream)))))
+
+      (ert-info ("Custom connect function")
+        (let ((erc-server-connect-function 'my-connect-func))
+          (erc-tls)
+          (should (equal (pop calls)
+                         '("irc.libera.chat" 6697 "tester" "unknown" t
+                           nil nil nil nil nil "user" nil)))
+          (should (equal (pop env)
+                         '((erc-server-connect-function my-connect-func))))))
+
+      (ert-info ("Advised default function overlooked") ; intentional
+        (advice-add 'erc-server-connect-function :around #'ignore
+                    '((name . erc-tests--erc-tls)))
+        (erc-tls)
+        (should (equal (pop calls)
+                       '("irc.libera.chat" 6697 "tester" "unknown" t
+                         nil nil nil nil nil "user" nil)))
+        (should (equal (pop env)
+                       '((erc-server-connect-function erc-open-tls-stream))))
+        (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls))
+
+      (ert-info ("Advised non-default function honored")
+        (let ((f (lambda (&rest r) (ignore r))))
+          (cl-letf (((symbol-value 'erc-server-connect-function) f))
+            (advice-add 'erc-server-connect-function :around #'ignore
+                        '((name . erc-tests--erc-tls)))
+            (erc-tls)
+            (should (equal (pop calls)
+                           '("irc.libera.chat" 6697 "tester" "unknown" t
+                             nil nil nil nil nil "user" nil)))
+            (should (equal (pop env) `((erc-server-connect-function ,f))))
+            (advice-remove 'erc-server-connect-function
+                           'erc-tests--erc-tls)))))))
+
+;; See `erc-select-read-args' above for argument parsing.
+;; This only tests the "hidden" arguments.
+
+(ert-deftest erc--interactive ()
+  (let (calls env)
+    (cl-letf (((symbol-function 'user-login-name)
+               (lambda (&optional _) "tester"))
+              ((symbol-function 'erc-open)
+               (lambda (&rest r)
+                 (push `((erc-server-connect-function
+                          ,erc-server-connect-function))
+                       env)
+                 (push r calls))))
+
+      (ert-info ("Default click-through accept TLS upgrade")
+        (ert-simulate-keys "\r\r\r\ry\r"
+          (call-interactively #'erc))
+        (should (equal (pop calls)
+                       '("irc.libera.chat" 6697 "tester" "unknown" t nil
+                         nil nil nil nil "user" nil)))
+        (should (equal (pop env)
+                       '((erc-server-connect-function erc-open-tls-stream)))))
+
+      (ert-info ("Nick supplied, decline TLS upgrade")
+        (ert-simulate-keys "\r\rdummy\r\rn\r"
+          (call-interactively #'erc))
+        (should (equal (pop calls)
+                       '("irc.libera.chat" 6667 "dummy" "unknown" t nil
+                         nil nil nil nil "user" nil)))
+        (should (equal (pop env)
+                       '(
+                         (erc-server-connect-function
+                          erc-open-network-stream))))))))
 
 (defun erc-tests--make-server-buf (name)
   (with-current-buffer (get-buffer-create name)