bug#53941: 27.2; socks + tor dont work with https

["J.P." <jp@neverwas.me>]

[-- Attachment #1: Type: text/plain, Size: 3485 bytes --]

v4. Include a minimal (hacky[1]) url-gw integration.

I'm now slightly of the opinion that offering no interface whatsoever is
probably too stark an approach. Ignoring the three Tor-related patches
for now, it seems that even without proper url.el integration[2], we can
still try to ensure that for most use cases, no unnecessary hackery need
apply.

Another issue is whether to address the questionable top-level advising
going on with `open-network-streams', since we're already refactoring
all the functions it affects. Assuming users exist who still have
`socks-override-functions' non-nil at load time, would it make sense to
warn them more fervently than would be done for a normal deprecation?
The thinking is that folks may be relying on this for things like
bypassing firewalls at work (and could therefore get dinged more than
usual just for upgrading Emacs).

As a start, I figured we could try and determine exactly why this
(perhaps somewhat ill-considered) top-level advising was ever instituted
in the first place[3]. AFAICT, it was mainly intended to

1. allow libraries calling `open-network-stream' (and unaware of
   `socks-open-network-stream') to proxy transparently[4]

2. guard the tunneled protocol from being accidentally subject to a
   recommencing of the SOCKS dialog

If anyone has better ideas, please share. Thanks.


Notes
~~~~~

[1] The second patch is new and a bit of an ugly hack. It has to do with
    this change from a while back:

      Do not set `url-gateway-method' in `url-https'
      commit 98c58df832975b01287ef749dd5235199d4cd431
      Sun Sep 28 20:00:54 2014 +0200

    which made it impossible for `url-gateway-method' to be respected by
    `url-open-stream' when called by `url-https'. But rather than
    undoing the offending portions out of hand, it might be nicer to
    first figure out how url-proxy.el is supposed to work and maybe get
    it and `url-retrieve-internal' (and `url-https') more in sync and
    sensitive to `url-gateway-method'.

[2] If we do end up with a proper url.el solution, it might then make
    more sense to emphasize the fact that `socks-open-network-stream' is
    really mostly about catering to url-gw (which it is). If that's
    agreeable, we could rename the following like so:

               socks-open-network-stream -> socks-url-open
        socks-open-network-stream-legacy -> socks-open-network-stream
      socks-open-network-stream-function -> socks-url-open-function

[3] A summary of the advice-based behavior triggered by
    `socks-override-functions', assuming `socks-find-route' returns
    non-nil:

    | topmost function invoked  | o-n-s advised | s-o-f | proxied |
    |---------------------------+---------------+-------+---------|
    | socks-open-network-stream | nil           | t     | yes     |
    | socks-open-network-stream | nil           | nil   | yes     |
    | socks-open-network-stream | t             | t     | yes     |
    | socks-open-network-stream | t             | nil   | yes     |
    | open-network-stream       | nil           | t     | no      |
    | open-network-stream       | nil           | nil   | no      |
    | open-network-stream       | t             | nil   | no      |
    | open-network-stream       | t             | t     | yes     |

    o-n-s: open-network-stream
    s-o-f: socks-override-functions

[4] It could be argued that the 2014 commit in [1] converted gw into one
    such library insofar as `url-https' is concerned.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-NOT-A-PATCH-v3-v4.diff --]
[-- Type: text/x-patch, Size: 9916 bytes --]

From 62062472fd14dc9911a105016badcc921d63ae95 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 6 Mar 2022 21:21:49 -0800
Subject: [PATCH 0/6] *** NOT A PATCH ***

*** BLURB HERE ***

F. Jason Park (6):
  Simplify network-stream opener in socks.el
  ; * lisp/url/url-gw.el (url-open-stream): Honor socks gateway-method
  Fix string encoding bug in socks tests
  Add support for SOCKS 4a
  Support SOCKS resolve extension
  [POC] Demo SOCKS resolve with HTTPS

 lisp/net/socks.el            | 145 ++++++++++++++++++++++++++++-------
 lisp/url/url-gw.el           |   2 +
 test/lisp/net/socks-tests.el | 113 +++++++++++++++++++++++++--
 3 files changed, 225 insertions(+), 35 deletions(-)

Interdiff:
diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 02edd95328..9285cbf805 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -334,22 +334,19 @@ socks-filter
 (defvar socks-override-functions nil
   "If non-nil, overwrite `open-network-stream' function with SOCKSified version.")
 (make-obsolete-variable 'socks-override-functions
-                        "use custom opener with `socks-open-stream-function'."
+                        "see `socks-open-network-stream-function'."
                         "29.1")
 
-(defvar socks-open-stream-function #'open-network-stream
-  "Function called to open a network stream connection.")
-
-(defun socks-open-connection (server-info &rest params)
+(defun socks-open-connection (server-info &rest kw-args)
   "Create and initialize a SOCKS process.
 Perform authentication if needed.  SERVER-INFO should resemble
-`socks-server'.  PARAMS are those accepted by `make-network-process'."
+`socks-server'.  KW-ARGS are those accepted by `open-network-stream'."
   (interactive)
-  (unless (plist-member params :coding)
-    (setf (plist-get params :coding) '(binary . binary)))
+  (unless (plist-member kw-args :coding)
+    (setf (plist-get kw-args :coding) '(binary . binary)))
   (save-excursion
-    (let ((proc (apply socks-open-stream-function "socks" nil
-                       (nth 1 server-info) (nth 2 server-info) params))
+    (let ((proc (apply #'open-network-stream "socks" nil
+                       (nth 1 server-info) (nth 2 server-info) kw-args))
 	  (authtype nil)
 	  version)
 
@@ -533,17 +530,31 @@ socks-find-services-entry
   (gethash (downcase service)
 	      (if udp socks-udp-services socks-tcp-services)))
 
-(defun socks-open-network-stream (name buffer host service &rest params)
+(defcustom socks-open-network-stream-function
+  #'socks-open-network-stream-legacy
+  "Function to open a SOCKS connection.
+Called with NAME, BUFFER, HOST, and SERVICE, for compatibility with
+similar functions in the url-gw framework.  May also be passed
+additional keyword args suitable for `make-network-process'."
+  :type '(choice (const :tag "Default fallback-oriented opener.")
+                 (function :tag "User-provided function")))
+
+(defun socks-open-network-stream-legacy (name buffer host service &rest params)
+  "Open a SOCKS connection for a valid route.
+Fall back to non-SOCKS connections for unknown or undesired routes."
   (if-let* ((route (socks-find-route host service))
             (proc (apply #'socks-open-connection route params)))
       (socks--open-network-stream proc buffer host service)
-    (message "Warning: no SOCKS route found for %s:%s" host service)
-    ;; Support legacy behavior (likely undesirable in most cases)
-    (apply socks-open-stream-function name buffer host service params)))
+    ;; Retain legacy behavior and connect anyway without warning
+    (apply #'open-network-stream name buffer host service params)))
+
+(defun socks-open-network-stream (name buffer host service &rest params)
+  "Open a SOCKS connection.  PARAMS are passed to `open-network-stream'."
+  (apply socks-open-network-stream-function name buffer host service params))
 
 (defun socks--open-network-stream (proc buffer host service)
   (progn ; temporarily preserve git blame for easier reviewing
-    (progn ; could rename to something like `socks--initiate-command-sequence'
+    (progn ; could rename to something like `socks--initiate-command-connect'
       (let* ((version (process-get proc 'socks-server-protocol))
              (atype
               (cond
@@ -685,34 +696,31 @@ socks-tor-resolve
   "Return list of one vector IPv4 address for domain NAME.
 Or return nil on failure.  See `network-lookup-address-info' for format
 of return value.  Server must support the Tor RESOLVE command."
-  (let ((socks-password (or socks-password ""))
-        host
-        (port 80)  ; unused for now
-        route
-        proc
-        ip)
-    (unless (string-suffix-p ".onion" name)
-      (setq host (if (string-match "\\`[[:ascii:]]+\\'" name)
-                     name
-                   (require 'puny)
-                   (puny-encode-domain name))
-            route (socks-find-route host port))
-      (cl-assert route)
-      ;; "Host unreachable" may be raised when the lookup fails
-      (unwind-protect
-          (progn
-            (setq proc (socks-open-connection route))
-            (socks-send-command proc
-                                socks-resolve-command
-                                socks-address-type-name
-                                host
-                                port)
-            (cl-assert (eq (process-get proc 'socks-state)
-                           socks-state-connected))
-            (setq ip (socks--extract-resolve-response proc)))
-        (when proc
-          (delete-process proc)))
-      (list (vconcat ip [0])))))
+  (let* ((socks-password (or socks-password ""))
+         (host (if (string-match "\\`[[:ascii:]]+\\'" name)
+                   name
+                 (require 'puny)
+                 (puny-encode-domain name)))
+         (port 80)  ; unused for now
+         (route (socks-find-route host nil))
+         proc
+         ip)
+    (cl-assert route)
+    ;; "Host unreachable" may be raised when the lookup fails
+    (unwind-protect
+        (progn
+          (setq proc (socks-open-connection route))
+          (socks-send-command proc
+                              socks-resolve-command
+                              socks-address-type-name
+                              host
+                              port)
+          (cl-assert (eq (process-get proc 'socks-state)
+                         socks-state-connected))
+          (setq ip (socks--extract-resolve-response proc)))
+      (when proc
+        (delete-process proc)))
+    (list (vconcat ip [0]))))
 
 (provide 'socks)
 
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index c4a41f56b3..822cbcb64e 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -215,6 +215,8 @@ url-open-stream
 Optional arg GATEWAY-METHOD specifies the gateway to be used,
 overriding the value of `url-gateway-method'."
   (unless url-gateway-unplugged
+    (when (eq url-gateway-method 'socks)
+      (setq gateway-method nil))
     (let* ((gwm (or gateway-method url-gateway-method))
            (gw-method (if (and url-gateway-local-host-regexp
                                (not (eq 'tls gwm))
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index f2600210b0..402ccf979d 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -348,6 +348,7 @@ test-socks-https-poc
   (ert-with-temp-file tempfile
     :prefix "emacs-test-socks-network-security-"
     (let* ((socks-server `("tor" ,@test-socks-service 5))
+           (socks-username "user")
            (socks-password "")
            (nsm-settings-file tempfile)
            (url-gateway-method 'socks)
@@ -361,25 +362,24 @@ test-socks-https-poc
                  (goto-char (point-min))
                  (should (search-forward "Congratulations" nil t))
                  (setq done t)))
-           (orig (symbol-function #'socks--open-network-stream)))
-      (cl-letf (((symbol-function 'socks--open-network-stream)
-                 (lambda (&rest rest)
-                   (let ((proc (apply orig rest)))
-                     (gnutls-negotiate :process proc :hostname host)
-                     (should (nsm-verify-connection proc host 443 t))))))
-        (ert-info ("Connect to HTTPS endpoint over Tor SOCKS proxy")
-          (unwind-protect
-              (progn
-                (advice-add 'network-lookup-address-info :override
-                            #'socks-tor-resolve)
-                (should-not (nsm-host-settings id))
-                (url-http url cb '(nil))
-                (ert-info ("Wait for response")
-                  (with-timeout (3 (error "Request timed out"))
-                    (unless done
-                      (sleep-for 0.1))))
-                (should (nsm-host-settings id)))
-            (advice-remove 'network-lookup-address-info
-                           #'socks-tor-resolve)))))))
+           (socks-open-network-stream-function
+            (lambda (&rest rest)
+              (let ((proc (apply #'socks-open-network-stream-legacy rest)))
+                (gnutls-negotiate :process proc :hostname host)
+                (should (nsm-verify-connection proc host 443 t))))))
+      (ert-info ("Connect to HTTPS endpoint over Tor SOCKS proxy")
+        (unwind-protect
+            (progn
+              (advice-add 'network-lookup-address-info :override
+                          #'socks-tor-resolve)
+              (should-not (nsm-host-settings id))
+              (url-https url cb '(nil))
+              (ert-info ("Wait for response")
+                (with-timeout (3 (error "Request timed out"))
+                  (unless done
+                    (sleep-for 0.1))))
+              (should (nsm-host-settings id)))
+          (advice-remove 'network-lookup-address-info
+                         #'socks-tor-resolve))))))
 
 ;;; socks-tests.el ends here
-- 
2.35.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0001-Simplify-network-stream-opener-in-socks.el.patch --]
[-- Type: text/x-patch, Size: 4765 bytes --]

From ed93ee2fdc8d6b920a44ddaa2b0571948cf77c88 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Tue, 1 Mar 2022 02:12:02 -0800
Subject: [PATCH 1/6] Simplify network-stream opener in socks.el

* lisp/net/socks.el (socks-override-functions): Make variable obsolete
and remove uses throughout.
(socks-open-connection): Accept additional `make-network-process'
params passed on to opener.
(socks-open-network-stream-function): Add new custom option to hold an
opener function.
(socks-open-network-stream-legacy): Simulate original
`socks-open-network-stream' functionality, only without
`socks-override-functions'.  Call `open-network-stream' as a fallback
when a route cannot be found.
(socks-open-network-stream): Accept additional params.  Delegate to
`socks-open-network-stream-function' for actual work.
(socks--open-network-stream): Reduce role to merely issuing the first
command using an existing process.
---
 lisp/net/socks.el | 65 +++++++++++++++++++++++++++--------------------
 1 file changed, 38 insertions(+), 27 deletions(-)

diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 8df0773e1d..fe66a94d18 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -323,19 +323,20 @@ socks-filter
 
 (defvar socks-override-functions nil
   "If non-nil, overwrite `open-network-stream' function with SOCKSified version.")
-
-(when socks-override-functions
-  (advice-add 'open-network-stream :around #'socks--open-network-stream))
-
-(defun socks-open-connection (server-info)
+(make-obsolete-variable 'socks-override-functions
+                        "see `socks-open-network-stream-function'."
+                        "29.1")
+
+(defun socks-open-connection (server-info &rest kw-args)
+  "Create and initialize a SOCKS process.
+Perform authentication if needed.  SERVER-INFO should resemble
+`socks-server'.  KW-ARGS are those accepted by `open-network-stream'."
   (interactive)
+  (unless (plist-member kw-args :coding)
+    (setf (plist-get kw-args :coding) '(binary . binary)))
   (save-excursion
-    (let ((proc
-           (let ((socks-override-functions nil))
-             (open-network-stream "socks"
-				  nil
-				  (nth 1 server-info)
-				  (nth 2 server-info))))
+    (let ((proc (apply #'open-network-stream "socks" nil
+                       (nth 1 server-info) (nth 2 server-info) kw-args))
 	  (authtype nil)
 	  version)
 
@@ -508,22 +509,32 @@ socks-find-services-entry
   (gethash (downcase service)
 	      (if udp socks-udp-services socks-tcp-services)))
 
-(defun socks-open-network-stream (name buffer host service)
-  (let ((socks-override-functions t))
-    (socks--open-network-stream
-     (lambda (&rest args)
-       (let ((socks-override-functions nil))
-         (apply #'open-network-stream args)))
-     name buffer host service)))
-
-(defun socks--open-network-stream (orig-fun name buffer host service &rest params)
-  (let ((route (and socks-override-functions
-                    (socks-find-route host service))))
-    (if (not route)
-	(apply orig-fun name buffer host service params)
-      ;; FIXME: Obey `params'!
-      (let* ((proc (socks-open-connection route))
-	     (version (process-get proc 'socks-server-protocol))
+(defcustom socks-open-network-stream-function
+  #'socks-open-network-stream-legacy
+  "Function to open a SOCKS connection.
+Called with NAME, BUFFER, HOST, and SERVICE, for compatibility with
+similar functions in the url-gw framework.  May also be passed
+additional keyword args suitable for `make-network-process'."
+  :type '(choice (const :tag "Default fallback-oriented opener.")
+                 (function :tag "User-provided function")))
+
+(defun socks-open-network-stream-legacy (name buffer host service &rest params)
+  "Open a SOCKS connection for a valid route.
+Fall back to non-SOCKS connections for unknown or undesired routes."
+  (if-let* ((route (socks-find-route host service))
+            (proc (apply #'socks-open-connection route params)))
+      (socks--open-network-stream proc buffer host service)
+    ;; Retain legacy behavior and connect anyway without warning
+    (apply #'open-network-stream name buffer host service params)))
+
+(defun socks-open-network-stream (name buffer host service &rest params)
+  "Open a SOCKS connection.  PARAMS are passed to `open-network-stream'."
+  (apply socks-open-network-stream-function name buffer host service params))
+
+(defun socks--open-network-stream (proc buffer host service)
+  (progn ; temporarily preserve git blame for easier reviewing
+    (progn ; could rename to something like `socks--initiate-command-connect'
+      (let* ((version (process-get proc 'socks-server-protocol))
              (atype
               (cond
                ((equal version 4)
-- 
2.35.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0002-lisp-url-url-gw.el-url-open-stream-Honor-socks-gatew.patch --]
[-- Type: text/x-patch, Size: 882 bytes --]

From a8bc5fe336356528dd0ebca86ec18ca541cb4b27 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 6 Mar 2022 17:14:50 -0800
Subject: [PATCH 2/6] ; * lisp/url/url-gw.el (url-open-stream): Honor socks
 gateway-method

---
 lisp/url/url-gw.el | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index c4a41f56b3..822cbcb64e 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -215,6 +215,8 @@ url-open-stream
 Optional arg GATEWAY-METHOD specifies the gateway to be used,
 overriding the value of `url-gateway-method'."
   (unless url-gateway-unplugged
+    (when (eq url-gateway-method 'socks)
+      (setq gateway-method nil))
     (let* ((gwm (or gateway-method url-gateway-method))
            (gw-method (if (and url-gateway-local-host-regexp
                                (not (eq 'tls gwm))
-- 
2.35.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: 0003-Fix-string-encoding-bug-in-socks-tests.patch --]
[-- Type: text/x-patch, Size: 3161 bytes --]

From e365303eeced26d5fc901e623eb44b3f6c2515cb Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 14 Feb 2022 02:36:57 -0800
Subject: [PATCH 3/6] Fix string encoding bug in socks tests

* test/lisp/net/socks-tests.el (socks-tests-canned-server-create,
socks-tests-filter-response-parsing-v4): Fix bug in process filter to
prevent prepared outgoing responses from being implicitly encoded as
utf-8.  Fix similar mistake in v4 filter test.
---
 test/lisp/net/socks-tests.el | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index 461796bdf9..d9ef53ae35 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -63,21 +63,21 @@ socks-tests-filter-response-parsing-v4
     (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
+      (socks-filter proc (unibyte-string 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])
+        (should (string= (unibyte-string 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])
+        (should (string= (unibyte-string 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)))))
@@ -140,10 +140,11 @@ socks-tests-canned-server-create
                    (unless (or (and (vectorp pat) (equal pat (vconcat line)))
                                (string-match-p pat line))
                      (error "Unknown request: %s" line))
+                   (setq resp (apply #'unibyte-string (append resp nil)))
                    (let ((print-escape-control-characters t))
                      (message "[%s] <- %s" name (prin1-to-string line))
                      (message "[%s] -> %s" name (prin1-to-string resp)))
-                   (process-send-string proc (concat resp)))))
+                   (process-send-string proc resp))))
          (serv (make-network-process :server 1
                                      :buffer (get-buffer-create name)
                                      :filter filt
-- 
2.35.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: 0004-Add-support-for-SOCKS-4a.patch --]
[-- Type: text/x-patch, Size: 4557 bytes --]

From bb2187da12d88e8b32f9fd005926342e116970c3 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 14 Feb 2022 02:36:57 -0800
Subject: [PATCH 4/6] Add support for SOCKS 4a

* lisp/net/socks.el (socks-server): Add new choice `4a' to version
field of option.  This may appear to change the type of the field from
a number to a union of symbols and numbers.  However,
`socks-send-command' and `socks-filter' already expect a possible
`http' value for this field (also a symbol).
(socks--errors-4): Add new constant containing error messages for
socks version 4.  The semantics are faithful, but the wording is
ad-libbed.
(socks-send-command): Massage existing handling for version 4 to
accommodate 4a.

* test/lisp/net/socks-tests.el (socks-tests-v4a-basic): add test for
4a.
Bug#53941
---
 lisp/net/socks.el            | 22 ++++++++++++++++++++--
 test/lisp/net/socks-tests.el | 13 +++++++++++++
 2 files changed, 33 insertions(+), 2 deletions(-)

diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index fe66a94d18..9f60ecbf36 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -162,6 +162,7 @@ socks-server
 	  (radio-button-choice :tag "SOCKS Version"
 			       :format "%t: %v"
 			       (const :tag "SOCKS v4  " :format "%t" :value 4)
+                               (const :tag "SOCKS v4a"  :format "%t" :value 4a)
 			       (const :tag "SOCKS v5"   :format "%t" :value 5))))
 
 
@@ -202,6 +203,12 @@ socks-errors
     "Command not supported"
     "Address type not supported"))
 
+(defconst socks--errors-4
+  '("Granted"
+    "Rejected or failed"
+    "Cannot connect to identd on the client"
+    "Client and identd report differing user IDs"))
+
 ;; The socks v5 address types
 (defconst socks-address-type-v4   1)
 (defconst socks-address-type-name 3)
@@ -401,6 +408,7 @@ socks-send-command
 		(format "%c%s" (length address) address))
 	       (t
 		(error "Unknown address type: %d" atype))))
+        trailing
 	request version)
     (or (process-get proc 'socks)
         (error "socks-send-command called on non-SOCKS connection %S" proc))
@@ -418,6 +426,12 @@ socks-send-command
 			     (t
 			      (error "Unsupported address type for HTTP: %d" atype)))
 			    port)))
+     ((when (eq version '4a)
+        (setf addr "\0\0\0\1"
+              trailing (concat address "\0")
+              version 4 ; done with the "a" part
+              (process-get proc 'socks-server-protocol) 4)
+        nil)) ; fall through
      ((equal version 4)
       (setq request (concat
 		     (unibyte-string
@@ -427,7 +441,8 @@ socks-send-command
 		      (logand port #xff)) ; port, low byte
 		     addr                 ; address
 		     (user-full-name)     ; username
-		     "\0")))              ; terminate username
+                     "\0"                 ; terminate username
+                     trailing)))          ; optional host to look up
      ((equal version 5)
       (setq request (concat
 		     (unibyte-string
@@ -448,7 +463,10 @@ socks-send-command
 	nil				; Sweet sweet success!
       (delete-process proc)
       (error "SOCKS: %s"
-             (nth (or (process-get proc 'socks-reply) 1) socks-errors)))
+             (let ((no (or (process-get proc 'socks-reply) 1)))
+               (if (eq version 5)
+                   (nth no socks-errors)
+                 (nth (+ 90 no) socks--errors-4)))))
     proc))
 
 \f
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index d9ef53ae35..4e990ffdba 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -207,6 +207,19 @@ socks-tests-v4-basic
                  (lambda (&optional _) "foo")))
         (socks-tests-perform-hello-world-http-request)))))
 
+(ert-deftest socks-tests-v4a-basic ()
+  "Show correct preparation of SOCKS4a connect command."
+  (let ((socks-server '("server" "127.0.0.1" 10083 4a))
+        (url-user-agent "Test/4a-basic")
+        (socks-tests-canned-server-patterns
+         `(([4 1 0 80 0 0 0 1 ?f ?o ?o 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0]
+            . [0 90 0 0 0 0 0 0])
+           ,socks-tests--hello-world-http-request-pattern)))
+    (ert-info ("Make HTTP request over SOCKS4A")
+      (cl-letf (((symbol-function 'user-full-name)
+                 (lambda (&optional _) "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
-- 
2.35.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: 0005-Support-SOCKS-resolve-extension.patch --]
[-- Type: text/x-patch, Size: 5979 bytes --]

From a33717db1379a661ba8007f924dc937feeb2ad1b Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 14 Feb 2022 02:36:57 -0800
Subject: [PATCH 5/6] Support SOCKS resolve extension

* lisp/net/socks.el (socks-resolve-command): Add new constant for the
SOCKS command RESOLVE, which comes by way of a nonstandard extension
from the TOR project.  It mirrors CONNECT in most respects but asks
the server to RESOLVE a host name and return its IP.  For details, see
https://github.com/torproject/torspec/blob/master/socks-extensions.txt
This shouldn't be confused with 5h/5-hostname, which is used to by
clients like cURL to allow users to bypass attempts to resolve a name
locally.
(socks--extract-resolve-response, socks-tor-resolve): Add utility
functions to query a SOCKS service supporting the RESOLVE extension.
Bug#53941
---
 lisp/net/socks.el            | 58 ++++++++++++++++++++++++++++++++++++
 test/lisp/net/socks-tests.el | 34 +++++++++++++++++++++
 2 files changed, 92 insertions(+)

diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 9f60ecbf36..9285cbf805 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -181,6 +181,9 @@ socks-udp-associate-command
 (defconst socks-authentication-null 0)
 (defconst socks-authentication-failure 255)
 
+;; Extensions
+(defconst socks-resolve-command #xf0)
+
 ;; Response codes
 (defconst socks-response-success               0)
 (defconst socks-response-general-failure       1)
@@ -664,6 +667,61 @@ socks-nslookup-host
 	res)
     host))
 
+(defun socks--extract-resolve-response (proc)
+  "Parse response for PROC and maybe return destination IP address."
+  (let ((response (process-get proc 'socks-response)))
+    (cl-assert response) ; otherwise, msg not received in its entirety
+    (pcase (process-get proc 'socks-server-protocol)
+      (4 ; https://www.openssh.com/txt/socks4a.protocol
+       (when-let (((zerop (process-get proc 'socks-reply)))
+                  ((eq (aref response 1) 90)) ; #x5a request granted
+                  (a (substring response 4)) ; ignore port for now
+                  ((not (string-empty-p a)))
+                  ((not (string= a "\0\0\0\0"))))
+         a))
+      (5 ; https://tools.ietf.org/html/rfc1928
+       (cl-assert (eq 5 (aref response 0)) t)
+       (pcase (aref response 3) ; ATYP
+         (1 (and-let* ((a (substring response 4 8))
+                       ((not (string= a "\0\0\0\0")))
+                       a)))
+         ;; No reason to support RESOLVE_PTR [F1] extension, right?
+         (3 (let ((len (1- (aref response 4))))
+              (substring response 5 (+ 5 len))))
+         (4 (substring response 4 20)))))))
+
+(declare-function puny-encode-domain "puny" (domain))
+
+(defun socks-tor-resolve (name &optional _family)
+  "Return list of one vector IPv4 address for domain NAME.
+Or return nil on failure.  See `network-lookup-address-info' for format
+of return value.  Server must support the Tor RESOLVE command."
+  (let* ((socks-password (or socks-password ""))
+         (host (if (string-match "\\`[[:ascii:]]+\\'" name)
+                   name
+                 (require 'puny)
+                 (puny-encode-domain name)))
+         (port 80)  ; unused for now
+         (route (socks-find-route host nil))
+         proc
+         ip)
+    (cl-assert route)
+    ;; "Host unreachable" may be raised when the lookup fails
+    (unwind-protect
+        (progn
+          (setq proc (socks-open-connection route))
+          (socks-send-command proc
+                              socks-resolve-command
+                              socks-address-type-name
+                              host
+                              port)
+          (cl-assert (eq (process-get proc 'socks-state)
+                         socks-state-connected))
+          (setq ip (socks--extract-resolve-response proc)))
+      (when proc
+        (delete-process proc)))
+    (list (vconcat ip [0]))))
+
 (provide 'socks)
 
 ;;; socks.el ends here
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index 4e990ffdba..3d1aca9af4 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -295,4 +295,38 @@ socks-tests-v5-auth-none
       (socks-tests-perform-hello-world-http-request)))
   (should (assq 2 socks-authentication-methods)))
 
+(ert-deftest tor-resolve-4a ()
+  "Make request to TOR resolve service over SOCKS4a"
+  (let* ((socks-server '("server" "127.0.0.1" 19050 4a))
+         (socks-tests-canned-server-patterns
+          '(([4 #xf0 0 80 0 0 0 1 ?f ?o ?o 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0]
+             . [0 90 0 0 93 184 216 34])))
+         (inhibit-message noninteractive)
+         (server (socks-tests-canned-server-create)))
+    (ert-info ("Query TOR RESOLVE service over SOCKS4")
+      (cl-letf (((symbol-function 'user-full-name)
+                 (lambda (&optional _) "foo")))
+        (should (equal '([93 184 216 34 0])
+                       (socks-tor-resolve "example.com")))))
+    (kill-buffer (process-buffer server))
+    (delete-process server)))
+
+(ert-deftest tor-resolve-5 ()
+  "Make request to TOR resolve service over SOCKS5"
+  (let* ((socks-server '("server" "127.0.0.1" 19051 5))
+         (socks-username "foo")
+         (socks-authentication-methods (append socks-authentication-methods
+                                               nil))
+         (inhibit-message noninteractive)
+         (socks-tests-canned-server-patterns
+          '(([5 2 0 2] . [5 2])
+            ([1 3 ?f ?o ?o 0] . [1 0])
+            ([5 #xf0 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
+             . [5 0 0 1 93 184 216 34 0 0])))
+         (server (socks-tests-canned-server-create)))
+    (ert-info ("Query TOR RESOLVE service over SOCKS5")
+      (should (equal '([93 184 216 34 0]) (socks-tor-resolve "example.com"))))
+    (kill-buffer (process-buffer server))
+    (delete-process server)))
+
 ;;; socks-tests.el ends here
-- 
2.35.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #8: 0006-POC-Demo-SOCKS-resolve-with-HTTPS.patch --]
[-- Type: text/x-patch, Size: 3325 bytes --]

From 62062472fd14dc9911a105016badcc921d63ae95 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 14 Feb 2022 02:36:57 -0800
Subject: [PATCH 6/6] [POC] Demo SOCKS resolve with HTTPS

* test/lisp/net/socks-test.el (test-socks-https-poc): Provide
throwaway test demoing an HTTPS connection over a TOR proxy service.
---
 test/lisp/net/socks-tests.el | 55 +++++++++++++++++++++++++++++++++++-
 1 file changed, 54 insertions(+), 1 deletion(-)

diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index 3d1aca9af4..402ccf979d 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -21,7 +21,7 @@
 
 ;;; Code:
 
-(require 'ert)
+(require 'ert-x)
 (require 'socks)
 (require 'url-http)
 
@@ -329,4 +329,57 @@ tor-resolve-5
     (kill-buffer (process-buffer server))
     (delete-process server)))
 
+(defvar test-socks-service ; "127.0.0.1:1080" -> ("127.0.0.1", 1080)
+  (when-let ((present (getenv "TEST_SOCKS_SERVICE"))
+             (parts (split-string present ":")))
+    (list (car parts) (string-to-number (cadr parts)))))
+
+(declare-function gnutls-negotiate "gnutls"
+                  (&rest spec
+                         &key process type hostname priority-string
+                         trustfiles crlfiles keylist min-prime-bits
+                         verify-flags verify-error verify-hostname-error
+                         &allow-other-keys))
+
+(ert-deftest test-socks-https-poc ()
+  :tags '(:unstable)
+  (unless test-socks-service (ert-skip "SOCKS service missing"))
+  (unless (gnutls-available-p) (ert-skip "SOCKS resolve test needs GNUTLS"))
+  (ert-with-temp-file tempfile
+    :prefix "emacs-test-socks-network-security-"
+    (let* ((socks-server `("tor" ,@test-socks-service 5))
+           (socks-username "user")
+           (socks-password "")
+           (nsm-settings-file tempfile)
+           (url-gateway-method 'socks)
+           (id "sha1:df77269389e537fcc9a5fe61667133b5bb97d42e")
+           (host "check.torproject.org")
+           (url (url-generic-parse-url "https://check.torproject.org"))
+           ;;
+           done
+           ;;
+           (cb (lambda (&rest _r)
+                 (goto-char (point-min))
+                 (should (search-forward "Congratulations" nil t))
+                 (setq done t)))
+           (socks-open-network-stream-function
+            (lambda (&rest rest)
+              (let ((proc (apply #'socks-open-network-stream-legacy rest)))
+                (gnutls-negotiate :process proc :hostname host)
+                (should (nsm-verify-connection proc host 443 t))))))
+      (ert-info ("Connect to HTTPS endpoint over Tor SOCKS proxy")
+        (unwind-protect
+            (progn
+              (advice-add 'network-lookup-address-info :override
+                          #'socks-tor-resolve)
+              (should-not (nsm-host-settings id))
+              (url-https url cb '(nil))
+              (ert-info ("Wait for response")
+                (with-timeout (3 (error "Request timed out"))
+                  (unless done
+                    (sleep-for 0.1))))
+              (should (nsm-host-settings id)))
+          (advice-remove 'network-lookup-address-info
+                         #'socks-tor-resolve))))))
+
 ;;; socks-tests.el ends here
-- 
2.35.1