Fix bug 1173760 (proxy server for https). Add http::config options -proxynot, -proxyauth.

1 files changed, 302 insertions, 33 deletions

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 88685ec..fcb03e1 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -26,6 +26,8 @@ namespace eval http {
 	    -proxyhost {}
 	    -proxyport {}
 	    -proxyfilter http::ProxyRequired
+	    -proxynot {}
+	    -proxyauth {}
 	    -repost 0
 	    -threadlevel 0
 	    -urlencoding utf-8
@@ -470,7 +472,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     if {[info exists state(-command)] && (!$skipCB)
 	    && (![info exists state(done-command-cb)])} {
 	set state(done-command-cb) yes
-	if {[catch {namespace eval :: $state(-command) $token} err] && $errormsg eq ""} {
+	if {    [catch {namespace eval :: $state(-command) $token} err]
+	     && ($errormsg eq "")
+	} {
 	    set state(error) [list $err $errorInfo $errorCode]
 	    set state(status) error
 	}
@@ -886,20 +890,22 @@ proc http::reset {token {why reset}} {
 proc http::geturl {url args} {
     variable urlTypes
 
-    # The value is set in the namespace header of this file.  If the file has
-    # not been modified the value is "::http::socket".
-    set socketCmd [lindex $urlTypes(http) 1]
-
     # - If ::tls::socketCmd has its default value "::socket", change it to the
-    #   new value $socketCmd.
+    #   new value ::http::socketForTls.
     # - If the old value is different, then it has been modified either by the
     #   script or by the Tcl installation, and replaced by a new command.  The
     #   script or installation that modified ::tls::socketCmd is also
-    #   responsible for integrating ::http::socket into its own "new" command,
-    #   if it wishes to do so.
+    #   responsible for integrating ::http::socketForTls into its own "new"
+    #   command, if it wishes to do so.
+    # - Commands that open a socket:
+    #   - ::socket             - basic
+    #   - ::http::socket       - can use a thread to avoid blockage by slow DNS
+    #                            lookup.  See http::config option -threadlevel.
+    #   - ::http::socketForTls - as ::http::socket, but can also open a socket
+    #                            for HTTPS/TLS through a proxy.
 
     if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
-        set ::tls::socketCmd $socketCmd
+        set ::tls::socketCmd ::http::socketForTls
     }
 
     set token [CreateToken $url {*}$args]
@@ -1023,6 +1029,7 @@ proc http::CreateToken {url args} {
 	requestHeaders  {}
 	requestLine     {}
 	transfer        {}
+	proxyUsed       none
     }
     set state(-keepalive) $defaultKeepalive
     set state(-strict) $strict
@@ -1299,11 +1306,16 @@ proc http::CreateToken {url args} {
 	set state(-keepalive) 0
     }
 
-    # If we are using the proxy, we must pass in the full URL that includes
-    # the server name.
-    if {$phost ne ""} {
+    # Handle proxy requests here for http:// but not for https://
+    # The proxying for https is done in the ::http::socketForTls command.
+    # A proxy request for http:// needs the full URL in the HTTP request line,
+    # including the server name.
+    # The *tls* test below attempts to describe protocols in addition to
+    # "https on port 443" that use HTTP over TLS.
+    if {($phost ne "") && (![string match -nocase *tls* $defcmd])} {
 	set srvurl $url
 	set targetAddr [list $phost $pport]
+	set state(proxyUsed) HttpProxy
     } else {
 	set targetAddr [list $host $port]
     }
@@ -1316,7 +1328,7 @@ proc http::CreateToken {url args} {
     }
 
     set state(connArgs) [list $proto $phost $srvurl]
-    set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr]
+    set state(openCmd) [list {*}$defcmd {*}$sockopts -type $token {*}$targetAddr]
 
     # See if we are supposed to use a previously opened channel.
     # - In principle, ANY call to http::geturl could use a previously opened
@@ -1663,12 +1675,14 @@ proc http::OpenSocket {token DoLater} {
 	    ##Log pre socket opened, - token $token
 	    ##Log $state(openCmd) - token $token
 	    set sock [namespace eval :: $state(openCmd)]
-
+	    set state(sock) $sock
 	    # Normal return from $state(openCmd) always returns a valid socket.
+	    # A TLS proxy connection with 407 or other failure from the
+	    # proxy server raises an error.
+
 	    # Initialisation of a new socket.
 	    ##Log post socket opened, - token $token
 	    ##Log socket opened, now fconfigure - token $token
-	    set state(sock) $sock
 	    set delay [expr {[clock milliseconds] - $pre}]
 	    if {$delay > 3000} {
 		Log socket delay $delay - token $token
@@ -1684,7 +1698,15 @@ proc http::OpenSocket {token DoLater} {
         # Code above has set state(sock) $sock
         ConfigureNewSocket $token $sockOld $DoLater
     } result errdict]} {
-        Finish $token $result
+        if {[string range $result 0 20] eq {proxy connect failed:}} {
+            # The socket can be persistent: if so it is identified with
+            # the https target host, and will be kept open.
+            # Results of the failed proxy CONNECT have been copied to $token and
+            # are available to the caller.
+            Eot $token
+        } else {
+            Finish $token $result
+        }
     }
     ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token
     return
@@ -1715,7 +1737,8 @@ proc http::OpenSocket {token DoLater} {
 #
 # Arguments:
 # token         - connection token (name of an array)
-# sockOld       - handle or placeholder used for a socket before the call to OpenSocket
+# sockOld       - handle or placeholder used for a socket before the call to
+#                 OpenSocket
 # DoLater       - dictionary of boolean values listing unfinished tasks
 #
 # Return Value: none
@@ -2083,9 +2106,15 @@ proc http::Connected {token proto phost srvurl} {
     Log ^B$tk begin sending request - token $token
 
     if {[catch {
-	set state(method) $how
-	set state(requestHeaders) {}
-	set state(requestLine) "$how $srvurl HTTP/$state(-protocol)"
+	if {[info exists state(bypass)]} {
+	    set state(method) [lindex [split $state(bypass) { }] 0]
+	    set state(requestHeaders) {}
+	    set state(requestLine) $state(bypass)
+	} else {
+	    set state(method) $how
+	    set state(requestHeaders) {}
+	    set state(requestLine) "$how $srvurl HTTP/$state(-protocol)"
+	}
 	puts $sock $state(requestLine)
 	set hostValue [GetFieldValue $state(-headers) Host]
 	if {$hostValue ne {}} {
@@ -2119,6 +2148,11 @@ proc http::Connected {token proto phost srvurl} {
 	    # and "state(-keepalive) 0".
 	    set ConnVal close
 	}
+        # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
+        # Pat Thoyts).
+        if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
+	    SendHeader $token Proxy-Authorization $http(-proxyauth)
+        }
 	# RFC7230 A.1 - "clients are encouraged not to send the
 	# Proxy-Connection header field in any requests"
 	set accept_encoding_seen 0
@@ -2143,7 +2177,12 @@ proc http::Connected {token proto phost srvurl} {
 		set contDone 1
 		set state(querylength) $value
 	    }
-	    if {[string equal -nocase $key "connection"]} {
+	    if {    [string equal -nocase $key "connection"]
+	         && [info exists state(bypass)]
+	    } {
+		# Value supplied in -headers overrides $ConnVal.
+		set connection_seen 1
+	    } elseif {[string equal -nocase $key "connection"]} {
 		# Remove "close" or "keep-alive" and use our own value.
 		# In an upgrade request, the upgrade is not guaranteed.
 		# Value "close" or "keep-alive" tells the server what to do
@@ -3121,6 +3160,7 @@ proc http::responseInfo {token} {
         currentPost           STATE  queryoffset
         totalSize             STATE  totalsize
         currentSize           STATE  currentsize
+        proxyUsed             STATE  proxyUsed
     } {
         if {$origin eq {STATE}} {
             if {[info exists state($name)]} {
@@ -3604,6 +3644,45 @@ proc http::Event {sock token} {
 		    set state(state) complete
 		    Eot $token
 		    return
+		} elseif {
+			($state(method) eq {CONNECT})
+		     && [string is integer -strict $state(responseCode)]
+		     && ($state(responseCode) >= 200)
+		     && ($state(responseCode) < 300)
+		} {
+		    # A successful CONNECT response has no body.
+		    # (An unsuccessful CONNECT has headers and body.)
+		    # The code below is abstracted from Eot/Finish, but
+		    # keeps the socket open.
+		    catch {fileevent $state(sock) readable {}}
+		    catch {fileevent $state(sock) writable {}}
+		    set state(state) complete
+		    set state(status) ok
+		    if {[info commands ${token}--EventCoroutine] ne {}} {
+			rename ${token}--EventCoroutine {}
+		    }
+		    if {[info commands ${token}--SocketCoroutine] ne {}} {
+			rename ${token}--SocketCoroutine {}
+		    }
+		    if {[info exists state(socketcoro)]} {
+		        Log $token Cancel socket after-idle event (Finish)
+		        after cancel $state(socketcoro)
+		        unset state(socketcoro)
+		    }
+		    if {[info exists state(after)]} {
+			after cancel $state(after)
+			unset state(after)
+		    }
+		    if {    [info exists state(-command)]
+			 && (![info exists state(done-command-cb)])
+		    } {
+			set state(done-command-cb) yes
+			if {[catch {namespace eval :: $state(-command) $token} err]} {
+			    set state(error) [list $err $errorInfo $errorCode]
+			    set state(status) error
+			}
+		    }
+		    return
 		} else {
 		}
 
@@ -4305,7 +4384,7 @@ proc http::CopyDone {token count {error {}}} {
 #	reason	- "eof" means premature EOF (not EOF as the natural end of
 #		  the response)
 #		- "" means completion of response, with or without EOF
-#		- anything else describes an error confition other than
+#		- anything else describes an error condition other than
 #		  premature EOF.
 #
 # Side Effects
@@ -4537,17 +4616,23 @@ proc http::quoteString {string} {
 
 proc http::ProxyRequired {host} {
     variable http
-    if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
-	if {
-	    ![info exists http(-proxyport)] ||
-	    ![string length $http(-proxyport)]
-	} {
-	    set http(-proxyport) 8080
-	}
-	return [list $http(-proxyhost) $http(-proxyport)]
+    if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
+        return
+    }
+    if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
+	set port 8080
     } else {
-	return
+	set port $http(-proxyport)
+    }
+
+    # Simple test (cf. autoproxy) for hosts that must be accessed directly,
+    # not through the proxy server.
+    foreach domain $http(-proxynot) {
+        if {[string match -nocase $domain $host]} {
+            return {}
+        }
     }
+    return [list $http(-proxyhost) $port]
 }
 
 # http::CharsetToEncoding --
@@ -4730,6 +4815,190 @@ interp alias {} http::meta {} http::responseHeaders
 interp alias {} http::metaValue {} http::responseHeaderValue
 interp alias {} http::ncode {} http::responseCode
 
+
+# ------------------------------------------------------------------------------
+#  Proc http::socketForTls
+# ------------------------------------------------------------------------------
+# Command to use in place of ::socket as the value of ::tls::socketCmd.
+# This command does the same as http::socket, and also handles https connections
+# through a proxy server.
+#
+# Notes.
+# - The proxy server works differently for https and http.  This implementation
+#   is for https.  The proxy for http is implemented in http::CreateToken (in
+#   code that was previously part of http::geturl).
+# - This code implicitly uses the tls options set for https in a call to
+#   http::register, and does not need to call commands tls::*.  This simple
+#   implementation is possible because tls uses a callback to ::socket that can
+#   be redirected by changing the value of ::tls::socketCmd.
+#
+# Arguments:
+# args        - as for ::socket
+#
+# Return Value: a socket identifier
+# ------------------------------------------------------------------------------
+
+proc http::socketForTls {args} {
+    variable http
+    set host [lindex $args end-1]
+    set port [lindex $args end]
+    if {    ($http(-proxyfilter) ne {})
+         && (![catch {$http(-proxyfilter) $host} proxy])
+    } {
+        set phost [lindex $proxy 0]
+        set pport [lindex $proxy 1]
+    } else {
+        set phost {}
+        set pport {}
+    }
+    if {$phost eq ""} {
+        set sock [::http::socket {*}$args]
+    } else {
+        set sock [::http::SecureProxyConnect {*}$args $phost $pport]
+    }
+    return $sock
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc http::SecureProxyConnect
+# ------------------------------------------------------------------------------
+# Command to open a socket through a proxy server to a remote server for use by
+# tls. The caller must perform the tls handshake.
+#
+# Notes
+# - Based on patch supplied by Melissa Chawla in ticket 1173760, and
+#   Proxy-Authorization header cf. autoproxy by Pat Thoyts.
+# - Rewritten as a call to http::geturl, because response headers and body are
+#   needed if the CONNECT request fails.  CONNECT is implemented for this case
+#   only, by state(bypass).
+# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT.
+# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014),
+#   RFC 9112 (June 2022).
+#
+# Arguments:
+# args        - as for ::socket, ending in host, port; with proxy host, proxy
+#               port appended.
+#
+# Return Value: a socket identifier
+# ------------------------------------------------------------------------------
+proc http::AllDone {varName args} {
+    set $varName done
+    return
+}
+
+proc http::SecureProxyConnect {args} {
+    variable http
+    variable ConnectVar
+    variable ConnectCounter
+    set varName ::http::ConnectVar([incr ConnectCounter])
+
+    # Extract (non-proxy) target from args.
+    set host [lindex $args end-3]
+    set port [lindex $args end-2]
+    set args [lremove $args end-3 end-2]
+
+    # Proxy server URL for connection.
+    # This determines where the socket is opened.
+    set phost [lindex $args end-1]
+    set pport [lindex $args end]
+    if {[string first : $phost] != -1} {
+        # IPv6 address, wrap it in [] so we can append :pport
+        set phost "\[${phost}\]"
+    }
+    set url http://${phost}:${pport}
+    # Elements of args other than host and port are not used when
+    # AsyncTransaction opens a socket.  Those elements are -async and the
+    # -type $tokenName for the https transaction.  Option -async is used by
+    # AsyncTransaction anyway, and -type $tokenName should not be propagated:
+    # the proxy request adds its own -type value.
+
+    set targ [lsearch -exact $args -type]
+    if {$targ != -1} {
+        # Record in the token that this is a proxy call.
+        set token [lindex $args $targ+1]
+        upvar 0 ${token} state
+        set state(proxyUsed) SecureProxy
+        set tim $state(-timeout)
+    } else {
+        set tim 0
+    }
+    if {$tim == 0} {
+        # Do not use infinite timeout for the proxy.
+        set tim 30000
+    }
+
+    # Prepare and send a CONNECT request to the proxy, using
+    # code similar to http::geturl.
+    set requestHeaders [list Host $host]
+    lappend requestHeaders Connection keep-alive
+    if {$http(-proxyauth) != {}} {
+        lappend requestHeaders Proxy-Authorization $http(-proxyauth)
+    }
+
+    set token2 [CreateToken $url -keepalive 0 -timeout $tim \
+            -headers $requestHeaders -command [list http::AllDone $varName]]
+    variable $token2
+    upvar 0 $token2 state2
+
+    # Setting this variable overrides the HTTP request line and allows
+    # -headers to override the Connection: header set by -keepalive.
+    set state2(bypass) "CONNECT $host:$port HTTP/1.1"
+
+    AsyncTransaction $token2
+
+    if {[info coroutine] ne {}} {
+        # All callers in the http package are coroutines launched by
+        # the event loop.
+        # The cwait command requires a coroutine because it yields
+        # to the caller; $varName is traced and the coroutine resumes
+        # when the variable is written.
+        cwait $varName
+    } else {
+        return -code error {code must run in a coroutine}
+        # For testing with a non-coroutine caller outside the http package.
+        # vwait $varName
+    }
+    unset $varName
+
+    set sock $state2(sock)
+    set code $state2(responseCode)
+    if {[string is integer -strict $code] && ($code >= 200) && ($code < 300)} {
+        # All OK.  The caller in tls will now call "tls::import $sock".
+        # Do not use Finish, which will close (sock).
+        # Other tidying done in http::Event.
+        array unset state2
+    } elseif {$targ != -1} {
+        # Bad HTTP status code; token is known.
+        # Copy from state2 to state, including (sock).
+        foreach name [array names state2] {
+            set state($name) $state2($name)
+        }
+        set state(proxyUsed) SecureProxy
+        set state(proxyFail) failed
+
+        # Do not use Finish, which will close (sock).
+        # Other tidying done in http::Event.
+        array unset state2
+
+        # Error message detected by http::OpenSocket.
+        return -code error "proxy connect failed: $code"
+    } else {
+        # Bad HTTP status code; token is not known because option -type
+        # (cf. targ) was not passed through tcltls, and so the script
+        # cannot write to state(*).
+        # Do not use Finish, which will close (sock).
+        # Other tidying done in http::Event.
+        array unset state2
+
+        # Error message detected by http::OpenSocket.
+        return -code error "proxy connect failed: $code\n$block"
+    }
+
+    return $sock
+}
+
+
 # ------------------------------------------------------------------------------
 #  Proc http::socket
 # ------------------------------------------------------------------------------
@@ -4767,7 +5036,7 @@ proc http::socket {args} {
 
     LoadThreadIfNeeded
 
-    set targ [lsearch -exact $args -token]
+    set targ [lsearch -exact $args -type]
     if {$targ != -1} {
         set token [lindex $args $targ+1]
         set args [lreplace $args $targ $targ+1]
@@ -4831,7 +5100,7 @@ proc http::socket {args} {
 }
 
 # The commands below are dependencies of http::socket and
-# are not used elsewhere.
+# http::SecureProxyConnect and are not used elsewhere.
 
 # ------------------------------------------------------------------------------
 #  Proc http::LoadThreadIfNeeded