Merge remote-tracking branch 'savannah/master' into HEAD

4 files changed, 608 insertions, 56 deletions

diff --git a/test/lisp/net/ntlm-resources/authinfo b/test/lisp/net/ntlm-resources/authinfo
new file mode 100644
index 00000000000..698391e9313
--- /dev/null
+++ b/test/lisp/net/ntlm-resources/authinfo
@@ -0,0 +1 @@
+machine localhost port http user ntlm password ntlm
diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el
index 6408ac13349..2420b3b48a9 100644
--- a/test/lisp/net/ntlm-tests.el
+++ b/test/lisp/net/ntlm-tests.el
@@ -17,11 +17,26 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
 
+;;; Commentary:
+
+;; Run this with `NTLM_TESTS_VERBOSE=1' to get verbose debugging.
+
+;;; Code:
+
 (require 'ert)
+(require 'ert-x)
 (require 'ntlm)
 
+(defsubst ntlm-tests-message (format-string &rest arguments)
+  "Print a message conditional on an environment variable being set.
+FORMAT-STRING and ARGUMENTS are passed to the message function."
+  (when (getenv "NTLM_TESTS_VERBOSE")
+    (apply #'message (concat "ntlm-tests: " format-string) arguments)))
+
+
 ;; This is the Lisp bignum implementation of `ntlm--time-to-timestamp',
 ;; for reference.
+
 (defun ntlm-tests--time-to-timestamp (time)
   "Convert TIME to an NTLMv2 timestamp.
 Return a unibyte string representing the number of tenths of a
@@ -49,4 +64,357 @@ signed integer.  TIME must be on the form (HIGH LOW USEC PSEC)."
     (should (equal (ntlm--time-to-timestamp time)
                    (ntlm-tests--time-to-timestamp time)))))
 
+(defvar ntlm-tests--username-oem "ntlm"
+  "The username for NTLM authentication tests, in OEM string encoding.")
+(defvar ntlm-tests--username-unicode
+  (ntlm-ascii2unicode ntlm-tests--username-oem
+		      (length ntlm-tests--username-oem))
+  "The username for NTLM authentication tests, in Unicode string encoding.")
+
+(defvar ntlm-tests--password "ntlm"
+  "The password used for NTLM authentication tests.")
+
+(defvar ntlm-tests--client-supports-unicode nil
+  "Non-nil if client supports Unicode strings.
+If client only supports OEM strings, nil.")
+
+(defvar ntlm-tests--challenge nil "The global random challenge.")
+
+(defun ntlm-server-build-type-2 ()
+  "Return an NTLM Type 2 message as a string.
+This string will be returned from the NTLM server to the NTLM client."
+  (let ((target (if ntlm-tests--client-supports-unicode
+		    (ntlm-ascii2unicode "DOMAIN" (length "DOMAIN"))
+		  "DOMAIN"))
+	(target-information ntlm-tests--password)
+	;; Flag byte 1 flags.
+	(_negotiate-unicode 1)
+	(negotiate-oem 2)
+	(request-target 4)
+	;; Flag byte 2 flags.
+	(negotiate-ntlm 2)
+	(_negotiate-local-call 4)
+	(_negotiate-always-sign 8)
+	;; Flag byte 3 flags.
+	(_target-type-domain 1)
+	(_target-type-server 2)
+	(target-type-share 4)
+	(_negotiate-ntlm2-key 8)
+	(negotiate-target-information 128)
+	;; Flag byte 4 flags, unused.
+	(_negotiate-128 32)
+	(_negotiate-56 128))
+    (concat
+     ;; Signature.
+     "NTLMSSP" (unibyte-string 0)
+     ;; Type 2.
+     (unibyte-string 2 0 0 0)
+     ;; Target length
+     (unibyte-string (length target) 0)
+     ;; Target allocated space.
+     (unibyte-string (length target) 0)
+     ;; Target offset.
+     (unibyte-string 48 0 0 0)
+     ;; Flags.
+     ;; Flag byte 1.
+     ;; Tell the client that this test server only supports OEM
+     ;; strings.  This test server will handle Unicode strings
+     ;; anyway though.
+     (unibyte-string (logior negotiate-oem request-target))
+     ;; Flag byte 2.
+     (unibyte-string negotiate-ntlm)
+     ;; Flag byte 3.
+     (unibyte-string (logior negotiate-target-information target-type-share))
+     ;; Flag byte 4.	Not sure what 2 means here.
+     (unibyte-string 2)
+     ;; Challenge.  Set this to (unibyte-string 1 2 3 4 5 6 7 8)
+     ;; instead of (ntlm-generate-nonce) to hold constant for
+     ;; debugging.
+     (setq ntlm-tests--challenge (ntlm-generate-nonce))
+     ;; Context.
+     (make-string 8 0)
+     (unibyte-string (length target-information) 0)
+     (unibyte-string (length target-information) 0)
+     (unibyte-string 54 0 0 0)
+     target
+     target-information)))
+
+(defun ntlm-server-hash (challenge blob username password)
+  "Hash CHALLENGE, BLOB, USERNAME and PASSWORD for a Type 3 check."
+  (hmac-md5 (concat challenge blob)
+	    (hmac-md5 (concat
+		       (upcase
+			;; This calculation always uses
+			;; Unicode username, even when the
+			;; server only supports OEM strings.
+			(ntlm-ascii2unicode username (length username))) "")
+		      (cadr (ntlm-get-password-hashes password)))))
+
+(defun ntlm-server-check-authorization (authorization-string)
+  "Return t if AUTHORIZATION-STRING correctly authenticates the user."
+  (let* ((binary (base64-decode-string
+		  (caddr (split-string authorization-string " "))))
+	 (_lm-response-length (md4-unpack-int16 (substring binary 12 14)))
+	 (_lm-response-offset
+	  (cdr (md4-unpack-int32 (substring binary 16 20))))
+	 (ntlm-response-length (md4-unpack-int16 (substring binary 20 22)))
+	 (ntlm-response-offset
+	  (cdr (md4-unpack-int32 (substring binary 24 28))))
+	 (ntlm-hash
+	  (substring binary ntlm-response-offset (+ ntlm-response-offset 16)))
+	 (username-length (md4-unpack-int16 (substring binary 36 38)))
+	 (username-offset (cdr (md4-unpack-int32 (substring binary 40 44))))
+	 (username (substring binary username-offset
+			      (+ username-offset username-length))))
+    (if (equal ntlm-response-length 24)
+	(let* ((expected
+		(ntlm-smb-owf-encrypt
+		 (cadr (ntlm-get-password-hashes ntlm-tests--password))
+		 ntlm-tests--challenge))
+	       (received (substring binary ntlm-response-offset
+				    (+ ntlm-response-offset
+				       ntlm-response-length))))
+	  (ntlm-tests-message "Got NTLMv1 response:")
+	  (ntlm-tests-message "Expected hash:     ===%S===" expected)
+	  (ntlm-tests-message "Got      hash:     ===%S===" received)
+	  (ntlm-tests-message "Expected username: ===%S==="
+			      ntlm-tests--username-oem)
+	  (ntlm-tests-message "Got      username: ===%S===" username)
+	  (and (or (equal username ntlm-tests--username-oem)
+		   (equal username ntlm-tests--username-unicode))
+	       (equal expected received)))
+      (let* ((ntlm-response-blob
+	      (substring binary (+ ntlm-response-offset 16)
+			 (+ (+ ntlm-response-offset 16)
+			    (- ntlm-response-length 16))))
+	     (_ntlm-timestamp (substring ntlm-response-blob 8 16))
+	     (_ntlm-nonce (substring ntlm-response-blob 16 24))
+	     (_target-length (md4-unpack-int16 (substring binary 28 30)))
+	     (_target-offset
+	      (cdr (md4-unpack-int32 (substring binary 32 36))))
+	     (_workstation-length (md4-unpack-int16 (substring binary 44 46)))
+	     (_workstation-offset
+	      (cdr (md4-unpack-int32 (substring binary 48 52)))))
+	(cond
+	 ;; This test server claims to only support OEM strings,
+	 ;; but also checks Unicode strings.
+	 ((or (equal username ntlm-tests--username-oem)
+	      (equal username ntlm-tests--username-unicode))
+	  (let* ((password ntlm-tests--password)
+		 (ntlm-hash-from-type-3 (ntlm-server-hash
+					 ntlm-tests--challenge
+					 ntlm-response-blob
+					 ;; Always -oem since
+					 ;; `ntlm-server-hash'
+					 ;; always converts it to
+					 ;; Unicode.
+					 ntlm-tests--username-oem
+					 password)))
+	    (ntlm-tests-message "Got NTLMv2 response:")
+	    (ntlm-tests-message "Expected hash: ==%S==" ntlm-hash)
+	    (ntlm-tests-message "Got      hash: ==%S==" ntlm-hash-from-type-3)
+	    (ntlm-tests-message "Expected username: ===%S==="
+				ntlm-tests--username-oem)
+	    (ntlm-tests-message "      or username: ===%S==="
+		     ntlm-tests--username-unicode)
+	    (ntlm-tests-message "Got      username: ===%S===" username)
+	    (equal ntlm-hash ntlm-hash-from-type-3)))
+	 (t
+	  nil))))))
+
+(require 'eieio)
+(require 'cl-lib)
+
+;; Silence some byte-compiler warnings that occur when
+;; web-server/web-server.el is not found.
+(declare-function ws-send nil)
+(declare-function ws-parse-request nil)
+(declare-function ws-start nil)
+(declare-function ws-stop-all nil)
+
+(require 'web-server nil t)
+(require 'url-http-ntlm nil t)
+
+(defun ntlm-server-do-token (request _process)
+  "Process an NTLM client's REQUEST.
+PROCESS is unused."
+  (with-slots (process headers) request
+    (let* ((header-alist (cdr headers))
+	   (authorization-header (assoc ':AUTHORIZATION header-alist))
+	   (authorization-string (cdr authorization-header)))
+      (if (and (stringp authorization-string)
+	       (string-match "NTLM " authorization-string))
+	  (let* ((challenge (substring authorization-string (match-end 0)))
+		 (binary (base64-decode-string challenge))
+		 (type (aref binary 8))
+		 ;; Flag byte 1 flags.
+		 (negotiate-unicode 1)
+		 (negotiate-oem 2)
+		 (flags-byte-1 (aref binary 12))
+		 (client-supports-unicode
+		  (not (zerop (logand flags-byte-1 negotiate-unicode))))
+		 (client-supports-oem
+		  (not (zerop (logand flags-byte-1 negotiate-oem))))
+		 (connection-header (assoc ':CONNECTION header-alist))
+		 (_keep-alive
+		  (when connection-header (cdr connection-header)))
+		 (response
+		  (cl-case type
+		    (1
+		     ;; Return Type 2 message.
+		     (when (and (not client-supports-unicode)
+				(not client-supports-oem))
+		       (warn (concat
+			      "Weird client supports neither Unicode"
+			      " nor OEM strings, using OEM.")))
+		     (setq ntlm-tests--client-supports-unicode
+			   client-supports-unicode)
+		     (concat
+		      "HTTP/1.1 401 Unauthorized\r\n"
+		      "WWW-Authenticate: NTLM "
+		      (base64-encode-string
+		       (ntlm-server-build-type-2) t) "\r\n"
+		      "WWW-Authenticate: Negotiate\r\n"
+		      "WWW-Authenticate: Basic realm=\"domain\"\r\n"
+		      "Content-Length: 0\r\n\r\n"))
+		    (3
+		     (if (ntlm-server-check-authorization
+			  authorization-string)
+			 "HTTP/1.1 200 OK\r\n\r\nAuthenticated.\r\n"
+		       (progn
+			 (if process
+			     (set-process-filter process nil)
+			   (error "Type 3 message found first?"))
+			 (concat "HTTP/1.1 401 Unauthorized\r\n\r\n"
+				 "Access Denied.\r\n")))))))
+	    (if response
+		(ws-send process response)
+	      (when process
+		(set-process-filter process nil)))
+	    (when (equal type 3)
+	      (set-process-filter process nil)
+	      (process-send-eof process)))
+	(progn
+	  ;; Did not get NTLM anything.
+	  (set-process-filter process nil)
+	  (process-send-eof process)
+	  (concat "HTTP/1.1 401 Unauthorized\r\n\r\n"
+		  "Access Denied.\r\n"))))))
+
+(defun ntlm-server-filter (process string)
+  "Read from PROCESS a STRING and treat it as a request from an NTLM client."
+  (let ((request (make-instance 'ws-request
+				:process process :pending string)))
+    (if (ws-parse-request request)
+	(ntlm-server-do-token request process)
+      (error "Failed to parse request"))))
+
+(defun ntlm-server-handler (request)
+  "Handle an HTTP REQUEST."
+  (with-slots (process headers) request
+    (let* ((header-alist (cdr headers))
+	   (authorization-header (assoc ':AUTHORIZATION header-alist))
+	   (connection-header (assoc ':CONNECTION header-alist))
+	   (keep-alive (when connection-header (cdr connection-header)))
+	   (response (concat
+		      "HTTP/1.1 401 Unauthorized\r\n"
+		      "WWW-Authenticate: Negotiate\r\n"
+		      "WWW-Authenticate: NTLM\r\n"
+		      "WWW-Authenticate: Basic realm=\"domain\"\r\n"
+		      "Content-Length: 0\r\n\r\n")))
+      (if (null authorization-header)
+	  ;; Tell client to use NTLM.	 Firefox will create a new
+	  ;; connection.
+	  (progn
+	    (process-send-string process response)
+	    (process-send-eof process))
+	(progn
+	  (ntlm-server-do-token request nil)
+	  (set-process-filter process #'ntlm-server-filter)
+	  (if (equal (upcase keep-alive) "KEEP-ALIVE")
+	      :keep-alive
+	    (error "NTLM server expects keep-alive connection header")))))))
+
+(defun ntlm-server-start ()
+  "Start an NTLM server on port 8080 for testing."
+  (ws-start 'ntlm-server-handler 8080))
+
+(defun ntlm-server-stop ()
+  "Stop the NTLM server."
+  (ws-stop-all))
+
+(defvar ntlm-tests--result-buffer nil "Final NTLM result buffer.")
+
+(require 'url)
+
+(defun ntlm-tests--url-retrieve-internal-around (original &rest arguments)
+  "Save the result buffer from a `url-retrieve-internal' to a global variable.
+ORIGINAL is the original `url-retrieve-internal' function and
+ARGUMENTS are passed to it."
+  (setq ntlm-tests--result-buffer (apply original arguments)))
+
+(defun ntlm-tests--authenticate ()
+  "Authenticate using credentials from the authinfo resource file."
+  (setq ntlm-tests--result-buffer nil)
+  (let ((auth-sources (list (ert-resource-file "authinfo")))
+	(auth-source-do-cache nil)
+	(auth-source-debug (when (getenv "NTLM_TESTS_VERBOSE") 'trivia)))
+    (ntlm-tests-message "Using auth-sources: %S" auth-sources)
+    (url-retrieve-synchronously "http://localhost:8080"))
+  (sleep-for 0.1)
+  (ntlm-tests-message "Results are in: %S" ntlm-tests--result-buffer)
+  (with-current-buffer ntlm-tests--result-buffer
+    (buffer-string)))
+
+(defun ntlm-tests--start-server-authenticate-stop-server ()
+  "Start an NTLM server, authenticate against it, then stop the server."
+  (advice-add #'url-retrieve-internal
+	      :around #'ntlm-tests--url-retrieve-internal-around)
+  (ntlm-server-stop)
+  (ntlm-server-start)
+  (let ((result (ntlm-tests--authenticate)))
+    (advice-remove #'url-retrieve-internal
+		   #'ntlm-tests--url-retrieve-internal-around)
+    (ntlm-server-stop)
+    result))
+
+(defvar ntlm-tests--successful-result
+  (concat "HTTP/1.1 200 OK\n\nAuthenticated." (unibyte-string 13) "\n")
+  "Expected result of successful NTLM authentication.")
+
+(require 'find-func)
+(defun ntlm-tests--ensure-ws-parse-ntlm-support ()
+  "Ensure NTLM special-case in `ws-parse'."
+  (let* ((hit (find-function-search-for-symbol
+	       'ws-parse nil (locate-file "web-server.el" load-path)))
+	 (buffer (car hit))
+	 (position (cdr hit)))
+    (with-current-buffer buffer
+      (goto-char position)
+      (search-forward-regexp
+       ":NTLM" (save-excursion (forward-sexp) (point)) t))))
+
+(require 'lisp-mnt)
+(defvar ntlm-tests--dependencies-present
+  (and (featurep 'url-http-ntlm)
+       (version<= "2.0.4"
+		  (lm-version (locate-file "url-http-ntlm.el" load-path)))
+       (featurep 'web-server)
+       (ntlm-tests--ensure-ws-parse-ntlm-support))
+  "Non-nil if GNU ELPA test dependencies were loaded.")
+
+(ert-deftest ntlm-authentication ()
+  "Check ntlm.el's implementation of NTLM authentication over HTTP."
+  (skip-unless ntlm-tests--dependencies-present)
+  (should (equal (ntlm-tests--start-server-authenticate-stop-server)
+		 ntlm-tests--successful-result)))
+
+(ert-deftest ntlm-authentication-old-compatibility-level ()
+  (skip-unless ntlm-tests--dependencies-present)
+  (setq ntlm-compatibility-level 0)
+  (should (equal (ntlm-tests--start-server-authenticate-stop-server)
+		 ntlm-tests--successful-result)))
+
 (provide 'ntlm-tests)
+
+;;; ntlm-tests.el ends here
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index b378ed2964e..71bdd74890a 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -21,68 +21,151 @@
 
 ;;; Code:
 
+(require 'ert)
 (require 'socks)
 (require 'url-http)
 
-(defvar socks-tests-canned-server-port nil)
+(ert-deftest socks-tests-auth-registration-and-suite-offer ()
+  (ert-info ("Default favors user/pass auth")
+    (should (equal socks-authentication-methods
+                   '((2 "Username/Password" . socks-username/password-auth)
+                     (0 "No authentication" . identity))))
+    (should (equal "\2\0\2" (socks-build-auth-list)))) ; length [offer ...]
+  (let (socks-authentication-methods)
+    (ert-info ("Empty selection/no methods offered")
+      (should (equal "\0" (socks-build-auth-list))))
+    (ert-info ("Simulate library defaults")
+      (socks-register-authentication-method 0 "No authentication"
+                                            'identity)
+      (should (equal socks-authentication-methods
+                     '((0 "No authentication" . identity))))
+      (should (equal "\1\0" (socks-build-auth-list)))
+      (socks-register-authentication-method 2 "Username/Password"
+                                            'socks-username/password-auth)
+      (should (equal socks-authentication-methods
+                     '((2 "Username/Password" . socks-username/password-auth)
+                       (0 "No authentication" . identity))))
+      (should (equal "\2\0\2" (socks-build-auth-list))))
+    (ert-info ("Removal")
+      (socks-unregister-authentication-method 2)
+      (should (equal socks-authentication-methods
+                     '((0 "No authentication" . identity))))
+      (should (equal "\1\0" (socks-build-auth-list)))
+      (socks-unregister-authentication-method 0)
+      (should-not socks-authentication-methods)
+      (should (equal "\0" (socks-build-auth-list))))))
 
-(defun socks-tests-canned-server-create (verbatim patterns)
-  "Create a fake SOCKS server and return the process.
+(ert-deftest socks-tests-filter-response-parsing-v4 ()
+  "Ensure new chunks added on right (Bug#45162)."
+  (let* ((buf (generate-new-buffer "*test-socks-filter*"))
+         (proc (start-process "test-socks-filter" buf "sleep" "1")))
+    (process-put proc 'socks t)
+    (process-put proc 'socks-state socks-state-waiting)
+    (process-put proc 'socks-server-protocol 4)
+    (ert-info ("Receive initial incomplete segment")
+      (socks-filter proc (concat [0 90 0 0 93 184 216]))
+      ;; From example.com: OK status ^      ^ msg start
+      (ert-info ("State still set to waiting")
+        (should (eq (process-get proc 'socks-state) socks-state-waiting)))
+      (ert-info ("Response field is nil because processing incomplete")
+        (should-not (process-get proc 'socks-response)))
+      (ert-info ("Scratch field holds stashed partial payload")
+        (should (string= (concat [0 90 0 0 93 184 216])
+                         (process-get proc 'socks-scratch)))))
+    (ert-info ("Last part arrives")
+      (socks-filter proc "\42") ; ?\" 34
+      (ert-info ("State transitions to complete (length check passes)")
+        (should (eq (process-get proc 'socks-state) socks-state-connected)))
+      (ert-info ("Scratch and response fields hold stash w. last chunk")
+        (should (string= (concat [0 90 0 0 93 184 216 34])
+                         (process-get proc 'socks-response)))
+        (should (string= (process-get proc 'socks-response)
+                         (process-get proc 'socks-scratch)))))
+    (delete-process proc)
+    (kill-buffer buf)))
 
-`VERBATIM' and `PATTERNS' are dotted alists containing responses.
-Requests are tried in order.  On failure, an error is raised."
-  (let* ((buf (generate-new-buffer "*canned-socks-server*"))
+(ert-deftest socks-tests-filter-response-parsing-v5 ()
+  "Ensure new chunks added on right (Bug#45162)."
+  (let* ((buf (generate-new-buffer "*test-socks-filter*"))
+         (proc (start-process "test-socks-filter" buf "sleep" "1")))
+    (process-put proc 'socks t)
+    (process-put proc 'socks-state socks-state-waiting)
+    (process-put proc 'socks-server-protocol 5)
+    (ert-info ("Receive initial incomplete segment")
+      ;; From fedora.org: 2605:bc80:3010:600:dead:beef:cafe:fed9
+      ;; 5004 ~~> Version Status (OK) NOOP Addr-Type (4 -> IPv6)
+      (socks-filter proc "\5\0\0\4\x26\x05\xbc\x80\x30\x10\x00\x60")
+      (ert-info ("State still waiting and response emtpy")
+        (should (eq (process-get proc 'socks-state) socks-state-waiting))
+        (should-not (process-get proc 'socks-response)))
+      (ert-info ("Scratch field holds partial payload of pending msg")
+        (should (string= "\5\0\0\4\x26\x05\xbc\x80\x30\x10\x00\x60"
+                         (process-get proc 'socks-scratch)))))
+    (ert-info ("Middle chunk arrives")
+      (socks-filter proc "\xde\xad\xbe\xef\xca\xfe\xfe\xd9")
+      (ert-info ("State and response fields still untouched")
+        (should (eq (process-get proc 'socks-state) socks-state-waiting))
+        (should-not (process-get proc 'socks-response)))
+      (ert-info ("Scratch contains new arrival appended (on RHS)")
+        (should (string=  (concat "\5\0\0\4"
+                                  "\x26\x05\xbc\x80\x30\x10\x00\x60"
+                                  "\xde\xad\xbe\xef\xca\xfe\xfe\xd9")
+                          (process-get proc 'socks-scratch)))))
+    (ert-info ("Final part arrives (port number)")
+      (socks-filter proc "\0\0")
+      (ert-info ("State transitions to complete")
+        (should (eq (process-get proc 'socks-state) socks-state-connected)))
+      (ert-info ("Scratch and response fields show last chunk appended")
+        (should (string=  (concat "\5\0\0\4"
+                                  "\x26\x05\xbc\x80\x30\x10\x00\x60"
+                                  "\xde\xad\xbe\xef\xca\xfe\xfe\xd9"
+                                  "\0\0")
+                          (process-get proc 'socks-scratch)))
+        (should (string= (process-get proc 'socks-response)
+                         (process-get proc 'socks-scratch)))))
+    (delete-process proc)
+    (kill-buffer buf)))
+
+(defvar socks-tests-canned-server-patterns nil
+  "Alist containing request/response cons pairs to be tried in order.
+Vectors must match verbatim. Strings are considered regex patterns.")
+
+(defun socks-tests-canned-server-create ()
+  "Create and return a fake SOCKS server."
+  (let* ((port (nth 2 socks-server))
+         (name (format "socks-server:%d" port))
+         (pats socks-tests-canned-server-patterns)
          (filt (lambda (proc line)
-                 (let ((resp (or (assoc-default line verbatim
-                                                (lambda (k s) ; s is line
-                                                  (string= (concat k) s)))
-                                 (assoc-default line patterns
-                                                (lambda (p s)
-                                                  (string-match-p p s))))))
-                   (unless resp
+                 (pcase-let ((`(,pat . ,resp) (pop pats)))
+                   (unless (or (and (vectorp pat) (equal pat (vconcat line)))
+                               (string-match-p pat line))
                      (error "Unknown request: %s" line))
                    (let ((print-escape-control-characters t))
-                     (princ (format "<- %s\n" (prin1-to-string line)) buf)
-                     (princ (format "-> %s\n" (prin1-to-string resp)) buf))
+                     (message "[%s] <- %s" name (prin1-to-string line))
+                     (message "[%s] -> %s" name (prin1-to-string resp)))
                    (process-send-string proc (concat resp)))))
-         (srv (make-network-process :server 1
-                                    :buffer buf
-                                    :filter filt
-                                    :name "server"
-                                    :family 'ipv4
-                                    :host 'local
-                                    :service socks-tests-canned-server-port)))
-    (set-process-query-on-exit-flag srv nil)
-    (princ (format "[%s] Listening on localhost:10080\n" srv) buf)
-    srv))
-
-;; Add ([5 3 0 1 2] . [5 2]) to the `verbatim' list below to validate
-;; against curl 7.71 with the following options:
-;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com
-;;
-;; If later implementing version 4a, try these:
-;; [4 1 0 80 0 0 0 1 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0] . [0 90 0 0 0 0 0 0]
-;; $ curl --verbose --proxy socks4a://127.0.0.1:10080 example.com
+         (serv (make-network-process :server 1
+                                     :buffer (get-buffer-create name)
+                                     :filter filt
+                                     :name name
+                                     :family 'ipv4
+                                     :host 'local
+                                     :coding 'binary
+                                     :service port)))
+    (set-process-query-on-exit-flag serv nil)
+    serv))
 
-(ert-deftest socks-tests-auth-filter-url-http ()
-  "Verify correct handling of SOCKS5 user/pass authentication."
-  (let* ((socks-server '("server" "127.0.0.1" 10080 5))
-         (socks-username "foo")
-         (socks-password "bar")
-         (url-gateway-method 'socks)
+(defvar socks-tests--hello-world-http-request-pattern
+  (cons "^GET /" (concat "HTTP/1.1 200 OK\r\n"
+                         "Content-Type: text/plain\r\n"
+                         "Content-Length: 13\r\n\r\n"
+                         "Hello World!\n")))
+
+(defun socks-tests-perform-hello-world-http-request ()
+  "Start canned server, validate hello-world response, and finalize."
+  (let* ((url-gateway-method 'socks)
          (url (url-generic-parse-url "http://example.com"))
-         (verbatim '(([5 2 0 2] . [5 2])
-                     ([1 3 ?f ?o ?o 3 ?b ?a ?r] . [1 0])
-                     ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
-                      . [5 0 0 1 0 0 0 0 0 0])))
-         (patterns
-          `(("^GET /" . ,(concat "HTTP/1.1 200 OK\r\n"
-                                 "Content-Type: text/plain; charset=UTF-8\r\n"
-                                 "Content-Length: 13\r\n\r\n"
-                                 "Hello World!\n"))))
-         (socks-tests-canned-server-port 10080)
-         (server (socks-tests-canned-server-create verbatim patterns))
-         (tries 10)
+         (server (socks-tests-canned-server-create))
          ;;
          done
          ;;
@@ -90,14 +173,112 @@ Requests are tried in order.  On failure, an error is raised."
                (goto-char (point-min))
                (should (search-forward "Hello World" nil t))
                (setq done t)))
-         (buf (url-http url cb '(nil))))
-    (ert-info ("Connect to HTTP endpoint over SOCKS5 with USER/PASS method")
-      (while (and (not done) (< 0 (cl-decf tries))) ; cl-lib via url-http
-        (sleep-for 0.1)))
+         (inhibit-message noninteractive)
+         (buf (url-http url cb '(nil)))
+         (proc (get-buffer-process buf))
+         (attempts 10))
+    (while (and (not done) (< 0 (cl-decf attempts)))
+      (sleep-for 0.1))
     (should done)
     (delete-process server)
+    (delete-process proc) ; otherwise seems client proc is sometimes reused
     (kill-buffer (process-buffer server))
     (kill-buffer buf)
     (ignore url-gateway-method)))
 
+;; Unlike curl, socks.el includes the ID field (but otherwise matches):
+;; $ curl --proxy socks4://127.0.0.1:1080 example.com
+
+(ert-deftest socks-tests-v4-basic ()
+  "Show correct preparation of SOCKS4 connect command (Bug#46342)."
+  (let ((socks-server '("server" "127.0.0.1" 10079 4))
+        (url-user-agent "Test/4-basic")
+        (socks-tests-canned-server-patterns
+         `(([4 1 0 80 93 184 216 34 ?f ?o ?o 0] . [0 90 0 0 0 0 0 0])
+           ,socks-tests--hello-world-http-request-pattern))
+        socks-nslookup-program)
+    (ert-info ("Make HTTP request over SOCKS4")
+      (cl-letf (((symbol-function 'socks-nslookup-host)
+                 (lambda (host)
+                   (should (equal host "example.com"))
+                   (list 93 184 216 34)))
+                ((symbol-function 'user-full-name)
+                 (lambda () "foo")))
+        (socks-tests-perform-hello-world-http-request)))))
+
+;; Replace first pattern below with ([5 3 0 1 2] . [5 2]) to validate
+;; against curl 7.71 with the following options:
+;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com
+
+(ert-deftest socks-tests-v5-auth-user-pass ()
+  "Verify correct handling of SOCKS5 user/pass authentication."
+  (should (assq 2 socks-authentication-methods))
+  (let ((socks-server '("server" "127.0.0.1" 10080 5))
+        (socks-username "foo")
+        (socks-password "bar")
+        (url-user-agent "Test/auth-user-pass")
+        (socks-tests-canned-server-patterns
+         `(([5 2 0 2] . [5 2])
+           ([1 3 ?f ?o ?o 3 ?b ?a ?r] . [1 0])
+           ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
+            . [5 0 0 1 0 0 0 0 0 0])
+           ,socks-tests--hello-world-http-request-pattern)))
+    (ert-info ("Make HTTP request over SOCKS5 with USER/PASS auth method")
+      (socks-tests-perform-hello-world-http-request))))
+
+;; Services (like Tor) may be configured without auth but for some
+;; reason still prefer the user/pass method over none when offered both.
+;; Given this library's defaults, the scenario below is possible.
+;;
+;; FYI: RFC 1929 doesn't say that a username or password is required
+;; but notes that the length of both fields should be at least one.
+;; However, both socks.el and curl send zero-length fields (though
+;; curl drops the user part too when the password is empty).
+;;
+;; From Tor's docs /socks-extensions.txt, 1.1 Extent of support:
+;; > We allow username/password fields of this message to be empty ...
+;; line 41 in blob 5fd1f828f3e9d014f7b65fa3bd1d33c39e4129e2
+;; https://gitweb.torproject.org/torspec.git/tree/socks-extensions.txt
+;;
+;; To verify against curl 7.71, swap out the first two pattern pairs
+;; with ([5 3 0 1 2] . [5 2]) and ([1 0 0] . [1 0]), then run:
+;; $ curl verbose -U "foo:" --proxy socks5h://127.0.0.1:10081 example.com
+
+(ert-deftest socks-tests-v5-auth-user-pass-blank ()
+  "Verify correct SOCKS5 user/pass authentication with empty pass."
+  (should (assq 2 socks-authentication-methods))
+  (let ((socks-server '("server" "127.0.0.1" 10081 5))
+        (socks-username "foo") ; defaults to (user-login-name)
+        (socks-password "") ; simulate user hitting enter when prompted
+        (url-user-agent "Test/auth-user-pass-blank")
+        (socks-tests-canned-server-patterns
+         `(([5 2 0 2] . [5 2])
+           ([1 3 ?f ?o ?o 0] . [1 0])
+           ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
+            . [5 0 0 1 0 0 0 0 0 0])
+           ,socks-tests--hello-world-http-request-pattern)))
+    (ert-info ("Make HTTP request over SOCKS5 with USER/PASS auth method")
+      (socks-tests-perform-hello-world-http-request))))
+
+;; Swap out ([5 2 0 1] . [5 0]) with the first pattern below to validate
+;; against curl 7.71 with the following options:
+;; $ curl --verbose --proxy socks5h://127.0.0.1:10082 example.com
+
+(ert-deftest socks-tests-v5-auth-none ()
+  "Verify correct handling of SOCKS5 when auth method 0 requested."
+  (let ((socks-server '("server" "127.0.0.1" 10082 5))
+        (socks-authentication-methods (append socks-authentication-methods
+                                              nil))
+        (url-user-agent "Test/auth-none")
+        (socks-tests-canned-server-patterns
+         `(([5 1 0] . [5 0])
+           ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
+            . [5 0 0 1 0 0 0 0 0 0])
+           ,socks-tests--hello-world-http-request-pattern)))
+    (socks-unregister-authentication-method 2)
+    (should-not (assq 2 socks-authentication-methods))
+    (ert-info ("Make HTTP request over SOCKS5 with no auth method")
+      (socks-tests-perform-hello-world-http-request)))
+  (should (assq 2 socks-authentication-methods)))
+
 ;;; socks-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 9a83fa66761..016b4d3c8f0 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -5102,8 +5102,10 @@ INPUT, if non-nil, is a string sent to the process."
 	     (string-match-p
 	      (regexp-quote envvar)
 	      ;; We must remove PS1, the output is truncated otherwise.
+	      ;; We must suppress "_=VAR...".
 	      (funcall
-	       this-shell-command-to-string "printenv | grep -v PS1")))))))))
+	       this-shell-command-to-string
+	       "printenv | grep -v PS1 | grep -v _=")))))))))
 
 (tramp--test--deftest-direct-async-process tramp-test33-environment-variables
   "Check that remote processes set / unset environment variables properly.