Merge pull request #1411 from tim-brown/http-connect-proxy

https and git proxying via HTTP CONNECT

pkgs/net-doc/net/scribblings/http-client.scrbl

@@ -1,6 +1,8 @@
 #lang scribble/doc
 @(require "common.rkt" scribble/bnf
           (for-label net/http-client
+                     net/win32-ssl
+                     racket/tcp
                      racket/list
                      openssl))
 
@@ -32,7 +34,7 @@ Returns a fresh HTTP connection.
 }
 
 @defproc[(http-conn-open! [hc http-conn?] [host (or/c bytes? string?)]
-                          [#:ssl? ssl? (or/c boolean? ssl-client-context? symbol?) #f]
+                          [#:ssl? ssl?  base-ssl?-tnl/c #f]
                           [#:port port (between/c 1 65535) (if ssl? 443 80)])
          void?]{
 
@@ -46,7 +48,7 @@ If @racket[hc] is live, the connection is closed.
 }
 
 @defproc[(http-conn-open [host (or/c bytes? string?)]
-                         [#:ssl? ssl? (or/c boolean? ssl-client-context? symbol?) #f]
+                         [#:ssl? ssl?  base-ssl?-tnl/c #f]
                          [#:port port (between/c 1 65535) (if ssl? 443 80)])
          http-conn?]{
 
@@ -138,7 +140,7 @@ Calls @racket[http-conn-send!] and @racket[http-conn-recv!] in sequence.
 }
 
 @defproc[(http-sendrecv [host (or/c bytes? string?)] [uri (or/c bytes? string?)]
-                        [#:ssl? ssl? (or/c boolean? ssl-client-context? symbol?) #f]
+                        [#:ssl? ssl? base-ssl?-tnl/c #f]
                         [#:port port (between/c 1 65535) (if ssl? 443 80)]
                         [#:version version (or/c bytes? string?) #"1.1"]                          
                         [#:method method (or/c bytes? string? symbol?) #"GET"]
@@ -157,6 +159,36 @@ response, which is why there is no @racket[#:closed?] argument like
 
 }
 
+@defproc[(http-conn-CONNECT-tunnel [proxy-host (or/c bytes? string?)]
+                                   [proxy-port (between/c 1 65535)]
+                                   [target-host (or/c bytes? string?)]
+                                   [target-port (between/c 1 65535)]
+                                   [#:ssl? ssl? base-ssl?/c #f])
+         (values base-ssl?/c input-port? output-port? (-> port? void?))]{
+Creates an HTTP connection to @racket[proxy-host] (on port @racket[proxy-port])
+ and invokes the HTTP ``CONNECT'' method to provide a tunnel to
+ @racket[target-host] (on port @racket[target-port]).
+
+ The SSL context or symbol, if any, provided in @racket[ssl?]
+ is applied to the gateway ports using @racket[ports->ssl-ports] (or @racket[ports->win32-ssl-ports]).
+
+ The function returns four values:
+ @itemize[
+ @item{If @racket[ssl?] was @racket[#f] then @racket[#f]. Otherwise an @racket[ssl-client-context?]
+       that has been negotiated with the target.
+       
+   If @racket[ssl?] was a protocol symbol, then a new @racket[ssl-client-context?] is created,
+   otherwise the current value of @racket[ssl?] is used}
+ @item{An @racket[input-port?] from the tunnelled service}
+ @item{An @racket[output-port?] to the tunnelled service}
+ @item{An abandon function, which when applied either returned port, will abandon it, in a manner
+   similar to @racket[tcp-abandon-port]}
+ ]
+ The SSL context or symbol, if any, provided in @racket[ssl?]
+ is applied to the gateway ports using @racket[ports->ssl-ports] (or @racket[ports->win32-ssl-ports])
+ and the negotiated client context is returned
+}
+
 @defthing[data-procedure/c chaperone-contract?]{
 
 Contract for a procedure that accepts a procedure of one
@@ -165,6 +197,25 @@ argument, which is a string or byte string:
 
 }
 
+@defthing[base-ssl?/c contract?]{
+ Base contract for the definition of the SSL context (passed in @racket[ssl?]) of an
+ @racket[http-conn-CONNECT-tunnel]:
+ 
+ @racket[(or/c boolean? ssl-client-context? symbol?)].
+
+ If @racket[ssl?] is not @racket[#f] then @racket[ssl?] is used as an argument to
+ @racket[ssl-connect] to, for example, check certificates.
+}
+
+@defthing[base-ssl?-tnl/c contract?]{
+ Contract for a @racket[base-ssl?/c] that might have been applied to a tunnel.
+ It is either a @racket[base-ssl?/c], or a @racket[base-ssl?/c] consed onto a list of an
+ @racket[input-port?], @racket[output-port?], and an abandon function
+ (e.g. @racket[tcp-abandon-port]):
+ 
+ @racket[(or/c base-ssl?/c (list/c base-ssl?/c input-port? output-port? (-> port? void?)))]
+}
+
 @section[#:tag "faq"]{Troubleshooting and Tips}
 
 @subsection{How do I send properly formatted POST form requests?}

pkgs/net-doc/net/scribblings/url.scrbl

@@ -2,6 +2,7 @@
 @(require "common.rkt" scribble/bnf
           (for-label net/url net/url-unit net/url-sig 
                      racket/list
+                     racket/tcp
                      net/head net/uri-codec net/tcp-sig
                      net/http-client
                      (only-in net/url-connect current-https-protocol)
@@ -478,12 +479,12 @@ When a @racket[header] argument is supplied, it is passed along to the
 The connection is made in such a way that the port is closed before
 @racket[call/input-url] returns, no matter how it returns. In
 particular, it is closed if @racket[handle] raises an exception, or if
-the connection process is interruped by an asynchronous break
+the connection process is interrupted by an asynchronous break
 exception.}
 
 @deftogether[(
 @defparam[current-proxy-servers mapping (listof (list/c string? string? (integer-in 0 65535)))]
-@defthing[proxiable-url-schemes (listof string?) #:value '("http")]
+@defthing[proxiable-url-schemes (listof string?) #:value '("http" "https" "git")]
  )]{
 
 The @racket[current-proxy-servers] parameter determines a mapping of proxy servers used for
@@ -492,7 +493,7 @@ connections. Each mapping is a list of three elements:
 @itemize[
 
  @item{the URL scheme, such as @racket["http"], where @racket[proxiable-url-schemes] lists the URL schemes
-  that can be proxied; currently, the only proxiable scheme is @racket["http"];}
+  that can be proxied}
 
  @item{the proxy server address; and}
 
@@ -500,16 +501,28 @@ connections. Each mapping is a list of three elements:
 
 ]
 
-The initial value of @racket[current-proxy-servers] is configured on demand from the
+The initial value of @racket[current-proxy-servers] is configured on demand from environment
-environment variables @indexed-envvar{plt_http_proxy} and @indexed-envvar{http_proxy},
+variables. Proxies for each URL scheme are configured from two variables each:
-where the former takes precedence over the latter.
+
+@itemize[
+ @item{@indexed-envvar{plt_http_proxy} and @indexed-envvar{http_proxy}, configure the HTTP
+   proxy, where the former takes precedence over the latter. HTTP requests will be proxied using an
+   HTTP proxy server connection}
+ @item{@indexed-envvar{plt_https_proxy} and @indexed-envvar{https_proxy}, configure the HTTPS
+   proxy, where the former takes precedence over the latter. HTTPS connections are proxied using an
+  HTTP ``CONNECT'' tunnel}
+ @item{@indexed-envvar{plt_git_proxy} and @indexed-envvar{git_proxy}, configure the GIT
+   proxy, where the former takes precedence over the latter. GIT connections are proxied using an
+  HTTP ``CONNECT'' tunnel}
+]
+ 
 Each environment variable contains a single URL of the form
-@litchar{http://}@nonterm{hostname}@litchar{:}@nonterm{portno}. If any other components of the URL are provided,
+@litchar{http://}@nonterm{hostname}@litchar{:}@nonterm{portno}.
-an error will be logged to a @racket[net/url] logger.
+If any other components of the URL are provided, a warning will be logged to a @racket[net/url]
+logger.
 
 The default mapping is the empty list (i.e., no proxies).}
 
-
 @defparam[current-no-proxy-servers dest-hosts-list (listof (or/c string? regexp?))]{
 
 A parameter that determines which servers will be accessed directly
@@ -579,6 +592,15 @@ This function does not support proxies.
                                                       
 }
 
+@defproc[(tcp-or-tunnel-connect [scheme string?]
+                                [host string?]
+                                [port (between/c 1 65535)])
+         (values input-port? output-port?)]{
+ If @racket[(proxy-server-for scheme host)], then the proxy is used to
+ @racket[http-conn-CONNECT-tunnel] to @racket[host] (on port @racket[port]).
+ 
+ Otherwise the call is equivalent to @racket[(tcp-connect host port)].}
+
 @section{URL HTTPS mode}
 
 @defmodule[net/url-connect]

pkgs/net-test/tests/net/http-client.rkt

@@ -295,4 +295,27 @@
     #"HEAD / HTTP/1.1\r\nHost: localhost:REDACTED\r\nUser-Agent: Racket/REDACTED (net/http-client)\r\nAccept-Encoding: gzip\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"
     #"HTTP/1.1 200 OK"
     '()
-    #""]))
+    #""])
+
+
+  (require (prefix-in es: "http-proxy/echo-server.rkt")
+           (prefix-in ps: "http-proxy/proxy-server.rkt"))
+
+  (define-values (es:server-thread es:shutdown-server)
+    (parameterize ([es:current-listen-port 12345]) (es:server)))
+
+  (define-values (ps:server-thread ps:shutdown-server)
+    (parameterize ([ps:current-listen-port 12380]) (ps:server)))
+
+  (check-equal?
+    (let-values (([ssl-ctx from to abandon-p]
+                  (hc:http-conn-CONNECT-tunnel "localhost" 12380 "localhost" 12345 #:ssl? #f)))
+      (fprintf to "MONKEYS\n")
+      (abandon-p to)
+      (begin0
+        (read-line from)
+        (abandon-p from)))
+    "MONKEYS")
+
+  (ps:shutdown-server)
+  (es:shutdown-server))

pkgs/net-test/tests/net/http-proxy/echo-server.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+(provide server current-listen-port current-conn-timeout)
+
+(require racket/port "generic-server.rkt")
+
+(define (server)
+  ;; Although this is ≡ (serve copy-port), I’m explicit about i and o
+  ;; to illustrate the calling convention for serve
+  (serve (lambda (i o) (copy-port i o))))
+
+(module+
+  main
+  (define-values (server-thread shutdown-server) (server))
+  (dynamic-wind
+   void
+   (λ () (thread-wait server-thread))
+   shutdown-server))
+
+(module+
+    test
+  (require rackunit racket/tcp)
+  (define-values (server-thread shutdown-server) (server))  
+  (dynamic-wind
+   void
+   (λ ()
+     (define-values (cl:from cl:to)
+       (tcp-connect "localhost" (current-listen-port)))
+     (file-stream-buffer-mode cl:to 'none)
+     (file-stream-buffer-mode cl:from 'none)
+     (fprintf cl:to "Monkeys!")
+     (flush-output cl:to)
+     (close-output-port cl:to)
+     (check-equal? (read-string 1024 cl:from) "Monkeys!")
+     (tcp-abandon-port cl:from))
+   shutdown-server))

pkgs/net-test/tests/net/http-proxy/generic-server.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+(provide serve
+         current-listen-port
+         current-conn-timeout)
+
+(require mzlib/thread
+         racket/tcp)
+
+(define current-listen-port (make-parameter 12345))
+
+(define current-conn-timeout (make-parameter #f))
+
+(define (serve conn-proc)
+  ;; use of semaphore `s` allows us to wait until the server is listening before continuing
+  ;; -- needed for test suites that “just want to get on with it”
+  (define s (make-semaphore 0))
+  (define t (thread
+             (λ ()
+               (run-server (current-listen-port)
+                           conn-proc
+                           (current-conn-timeout)
+                           void ; handler
+                           (λ (port-no
+                               (max-allow-wait 4)
+                               (reuse? #f)
+                               (hostname #f))
+                             (dynamic-wind
+                              void
+                              (λ () (tcp-listen port-no max-allow-wait reuse? hostname))
+                              (λ () (semaphore-post s))))))))
+  (semaphore-wait s)
+  (values t (λ () (kill-thread t))))
+
+;; tested via the echo-server (in this directory)
+;; (module+ test)

pkgs/net-test/tests/net/http-proxy/https-non-server.rkt

@@ -0,0 +1,49 @@
+#lang racket/base
+; It may look like an HTTPS server, but it very isn’t
+(provide server
+         current-listen-port
+         current-conn-timeout)
+
+(require racket/match
+         openssl
+         syntax/modresolve
+         "generic-server.rkt")
+
+(define (conn-proc i o)  
+  (define ssl-srvr-ctx (ssl-make-server-context 'secure))
+  (define test.pem-path (build-path
+                         (let-values (([base name mbd?]
+                                       (split-path (resolve-module-path 'openssl)))) base)
+                         "test.pem"))
+  (ssl-load-certificate-chain! ssl-srvr-ctx test.pem-path)
+  (ssl-load-private-key! ssl-srvr-ctx test.pem-path)
+  (define-values (s:i s:o)
+    (ports->ssl-ports i o
+                      #:mode 'accept
+                      #:context ssl-srvr-ctx
+                      #:close-original? #t
+                      #:shutdown-on-close? #t))
+  (define request-lines
+    (for/list ((l (in-lines s:i 'return-linefeed)) #:break (string=? l "")) l))
+  (define-syntax-rule (out/flush fmt args ...)
+    (begin (fprintf s:o fmt args ...) (flush-output s:o)))
+  
+  (match request-lines
+    [(cons (regexp #px"^(GET)\\s+(\\S+)(\\s+HTTP/\\S+)?$" (list _ method uri _)) _)
+     (define content (format "~s (but at least it's secure)" uri))
+     (out/flush
+      "HTTP/1.1 200 OK\r\nContent-type: text/html\r\nContent-length: ~a\r\n\r\n~a"
+      (string-length content) content)]
+    [(cons (regexp #px"^(\\S+)\\s+(\\S+)(\\s+HTTP/\\S+)?$"
+                   (list request method request-uri http-version)) _)
+     (out/flush "HTTP/1.1 405 Method Not Allowed\r\n\r\n")]
+    [_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")]))
+
+(define (server) (serve conn-proc))
+
+(module+
+  main
+  (define-values (server-thread shutdown-server) (server))
+  (dynamic-wind void (λ () (thread-wait server-thread)) shutdown-server))
+
+(module+ test)

pkgs/net-test/tests/net/http-proxy/proxy-server.rkt

@@ -0,0 +1,108 @@
+#lang racket/base
+;; A proxy HTTP server -- don’t get your hopes up it’s for testing and only proxies ports, probably
+;; oozes security leaks and I wouldn’t be surprised if it leaked fids too.
+(require racket/port racket/match racket/tcp "generic-server.rkt")
+
+(provide server
+         current-listen-port
+         current-conn-timeout)
+
+(define (http-tunnel-serve in out)
+  (let/ec
+    ec
+    (define-syntax-rule (out/flush fmt args ...)
+                        (begin (fprintf out fmt args ...)
+                               (flush-output out)))
+
+    (define request-lines (for/list ((l (in-lines in 'return-linefeed))
+                                     #:break (string=? l ""))
+                                    l))
+
+    ;; frankly, I don’t care about the headers... it’s just the request string
+    ;; I’m interested in
+    (match request-lines
+           [(cons (regexp #px"^(CONNECT)\\s+(\\S+):(\\d+)(\\s+HTTP/\\S+)?$"
+                          (list _ method connect-host (app string->number connect-port) _)) _)
+            (define-values (connect:from connect:to)
+              (with-handlers ([exn:fail? (lambda (x)
+                                           ;; any better ideas as to a good status code?
+                                           (out/flush "HTTP/1.1 410 Gone\r\n\r\n")
+                                           (ec))])
+                             (tcp-connect connect-host connect-port)))
+            (file-stream-buffer-mode connect:to 'none)
+            (file-stream-buffer-mode connect:from 'none)
+            (out/flush "HTTP/1.1 200 Connection Established\r\n\r\n")
+            (define copy-in-to-connect:to-thread
+              (thread (lambda ()
+                        (copy-port in connect:to)
+                        (close-output-port connect:to))))
+            (define copy-connect:from-to-out-thread
+              (thread (lambda ()
+                        (copy-port connect:from out)
+                        (close-output-port out))))
+            (thread-wait copy-in-to-connect:to-thread)
+            (thread-wait copy-connect:from-to-out-thread)]
+           [(cons (regexp #px"^(\\S+)\\s+(\\S+)(\\s+HTTP/\\S+)?$"
+                          (list request method request-uri http-version)) _)
+            (out/flush "HTTP/1.1 405 Method Not Allowed\r\n\r\n")]
+           [_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")])))
+
+(define (server)
+  (serve http-tunnel-serve))
+
+(module+
+  main
+  (define-values (server-thread shutdown-server)
+    (parameterize ([current-listen-port 12380]) (server)))
+  (thread-wait server-thread))
+
+(module+
+  test
+  (require rackunit)
+
+  (require (prefix-in es: "echo-server.rkt"))
+
+  (define proxy-listen-port 12380)
+
+  (define-values (server-thread shutdown-server)
+    (parameterize ([current-listen-port proxy-listen-port]) (server)))
+
+  (define-values (es:server-thread es:shutdown-server) (es:server))
+  
+  (let ((old-exit-handler (exit-handler)))
+    (exit-handler (lambda (exit-code)
+                    (shutdown-server)
+                    (es:shutdown-server)
+                    (old-exit-handler exit-code))))
+
+  (define (connect/test method uri http-version
+                        #:headers (headers '())
+                        #:body (body #f))
+
+    (define-values (cl:from cl:to) (tcp-connect "localhost" proxy-listen-port))
+    (file-stream-buffer-mode cl:from 'none)
+    (file-stream-buffer-mode cl:to 'none)
+
+    (if http-version
+      (fprintf cl:to "~a ~a ~a\r\n" method uri http-version)
+      (fprintf cl:to "~a ~a\r\n" method uri))
+
+    (for-each (lambda (h) (fprintf cl:to "~a\r\n" h)) headers)
+    (fprintf cl:to "\r\n") ; end headers
+
+    ;; Not interested in any fancy interaction here... just see what the response is
+    (when body (write-string body cl:to))
+    (flush-output cl:to)
+    (close-output-port cl:to)
+    (begin0
+      (port->string cl:from)
+      (tcp-abandon-port cl:to)
+      (tcp-abandon-port cl:from)))
+
+  (check-match (connect/test "GET" "/" #f) (regexp #px"^HTTP/\\S+\\s+405"))
+  (check-match (connect/test "A B" "/" #f) (regexp #px"^HTTP/\\S+\\s+400"))
+  (check-match (connect/test "CONNECT" "q.com:9887" #f) (regexp #px"^HTTP/\\S+\\s+410"))
+  (check-match (connect/test "CONNECT" "localhost:12345" #f #:body "blah blah blah!")
+               (regexp #px"^HTTP/\\S+\\s+200.*blah!$"))
+
+  )

pkgs/net-test/tests/net/url.rkt

@@ -2,6 +2,9 @@
 (require net/url
          tests/eli-tester)
 
+(require (prefix-in ss: "http-proxy/https-non-server.rkt")
+         (prefix-in ps: "http-proxy/proxy-server.rkt"))
+
 (provide tests)
 (module+ main (test do (tests)))
 (define (tests)
@@ -14,6 +17,10 @@
                                  (host #f)
                                  #:plt-http-proxy (plt-http-proxy #f)
                                  #:http-proxy (http-proxy #f)
+                                 #:plt-https-proxy (plt-https-proxy #f)
+                                 #:https-proxy (https-proxy #f)
+                                 #:plt-git-proxy (plt-git-proxy #f)
+                                 #:git-proxy (git-proxy #f)
                                  #:plt-no-proxy (plt-no-proxy #f)
                                  #:no-proxy (no-proxy #f))
     (parameterize ([current-environment-variables envar-stash]
@@ -22,10 +29,16 @@
         (environment-variables-set! envar-stash
                                     (string->bytes/locale name)
                                     (and val (string->bytes/locale val))))
-      (put! "plt_http_proxy" plt-http-proxy)
+      (for ((var.val (in-list `(("plt_http_proxy"  . ,plt-http-proxy)
-      (put! "http_proxy" http-proxy)
+                                ("plt_https_proxy" . ,plt-https-proxy)
-      (put! "plt_no_proxy" plt-no-proxy)
+                                ("plt_git_proxy"   . ,plt-git-proxy)
-      (put! "no_proxy" no-proxy)
+                                ("http_proxy"      . ,http-proxy)
+                                ("https_proxy"     . ,https-proxy)
+                                ("git_proxy"       . ,git-proxy)
+                                ("plt_no_proxy"    . ,plt-no-proxy)
+                                ("no_proxy"        . ,no-proxy)))))
+           (put! (car var.val) (cdr var.val)))
+
       (eval '(require net/url))
       (eval `(parameterize (,@(if current-proxy-servers-val
                                   `([current-proxy-servers (quote ,current-proxy-servers-val)])
@@ -34,18 +47,22 @@
                                   `([current-no-proxy-servers (quote ,current-no-proxy-servers-val)])
                                   null))
               (proxy-server-for ,schema ,host)))))
-    
+  
   (test
    ;; Test the current-proxy-servers parameter can be set
    (parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))])
      (current-proxy-servers))
    => '(("http" "proxy.com" 3128))
 
-   ;; we have at least http
+   ;; we have at least http, https, git
    (member "http" proxiable-url-schemes)
+   (member "https" proxiable-url-schemes)
+   (member "git" proxiable-url-schemes)
 
    ;; by default, there are no proxy servers
    (test-proxy-server-for "http") => #f
+   (test-proxy-server-for "https") => #f
+   (test-proxy-server-for "git") => #f
 
    ;; current-no-proxy-servers converts incoming strings to anchored regexps
    (parameterize ([current-no-proxy-servers (list "test.racket-lang.org"
@@ -55,7 +72,7 @@
         #rx".*\\.racket-lang\\.org")
 
    ;; ------------------------------------------------------------------
-   ;; Test Proxy Servers (loading from environment and proxy-server-for)
+   ;; HTTP: Test Proxy Servers (loading from environment and proxy-server-for)
    
    ;; proxy servers set in current-proxy-servers are not overridden by environment
    (test-proxy-server-for #:current-proxy-servers '(("http" "proxy.com" 3128))
@@ -75,6 +92,48 @@
                           "http" "test.racket-lang.org")
    => '("http" "proxy.net" 3228)
 
+   ;; ------------------------------------------------------------------
+   ;; HTTPS: Test Proxy Servers (loading from environment and proxy-server-for)
+   
+   ;; proxy servers set in current-proxy-servers are not overridden by environment
+   (test-proxy-server-for #:current-proxy-servers '(("https" "proxy.com" 3128))
+                          #:plt-https-proxy "http://proxy.net:1234"
+                          #:https-proxy "http://proxy.net:1234"
+                          "https" "test.racket-lang.org")
+   => '("https" "proxy.com" 3128)
+
+   ;; plt_https_proxy is is prioritised over https_proxy
+   (test-proxy-server-for #:plt-https-proxy "http://proxy.net:3128"
+                          #:https-proxy "http://proxy.net:3228"
+                          "https" "test.racket-lang.org")
+   => '("https" "proxy.net" 3128)
+
+   ;; otherwise fall back to https_proxy
+   (test-proxy-server-for #:https-proxy "http://proxy.net:3228"
+                          "https" "test.racket-lang.org")
+   => '("https" "proxy.net" 3228)
+
+   ;; ------------------------------------------------------------------
+   ;; GIT: Test Proxy Servers (loading from environment and proxy-server-for)
+   
+   ;; proxy servers set in current-proxy-servers are not overridden by environment
+   (test-proxy-server-for #:current-proxy-servers '(("git" "proxy.com" 3128))
+                          #:plt-git-proxy "http://proxy.net:1234"
+                          #:git-proxy "http://proxy.net:1234"
+                          "git" "test.racket-lang.org")
+   => '("git" "proxy.com" 3128)
+
+   ;; plt_git_proxy is is prioritised over git_proxy
+   (test-proxy-server-for #:plt-git-proxy "http://proxy.net:3128"
+                          #:git-proxy "http://proxy.net:3228"
+                          "git" "test.racket-lang.org")
+   => '("git" "proxy.net" 3128)
+
+   ;; otherwise fall back to git_proxy
+   (test-proxy-server-for #:git-proxy "http://proxy.net:3228"
+                          "git" "test.racket-lang.org")
+   => '("git" "proxy.net" 3228)
+
    ;; ---------------------------------------------------------------------
    ;; Test NO Proxy Servers (loading from environment and proxy-server-for)
    ;; no proxy servers accumulate (they don't override), so test each one
@@ -134,6 +193,21 @@
                              #:current-no-proxy-servers '(#rx".racket-lang.org")
                              "http" "test.bracket-lang.org")
    => #f
-  ))
+  )
+
+  (define-values (ss:server-thread ss:shutdown-server)
+    (parameterize ([ss:current-listen-port 12345]) (ss:server)))
+
+  (define-values (ps:server-thread ps:shutdown-server)
+    (parameterize ([ps:current-listen-port 12380]) (ps:server)))
+
+  (test (parameterize ([current-proxy-servers '(("https" "localhost" 12380))])
+          (port->string (get-pure-port (string->url "https://localhost:12345/woo/yay"))))
+        => "\"/woo/yay\" (but at least it's secure)")
+
+  (ps:shutdown-server)
+  (ss:shutdown-server)
+
+)
 
 (module+ test (require (submod ".." main))) ; for raco test & drdr

racket/collects/net/git-checkout.rkt

@@ -203,7 +203,7 @@
 (define (initial-connect transport host verify? port repo status)
   (case transport
     [(git)
-     (define-values (i o) (tcp-connect host port))
+     (define-values (i o) (tcp-or-tunnel-connect "git" host port))
      (values i o #f)]
     [(http https)
      (define url-str

racket/collects/net/http-client.rkt

@@ -63,7 +63,15 @@
   (define ssl-version (if (boolean? ssl?) 'auto ssl?))
 
   (define-values (from to)
-    (cond [ssl?
+    (cond [(list? ssl?)
+           ;; At this point, we have a tunneled socket to the remote host/port: we do not need to
+           ;; address it; ignore host-bs, only use port for conn-port-usual?
+           (match-define (list ssl-ctx? (? input-port? t:from) (? output-port? t:to) abandon-p) ssl?)
+           (set-http-conn-abandon-p! hc abandon-p)
+           (set-http-conn-port-usual?! hc (or (and ssl-ctx? (= 443 port))
+                                              (and (not ssl-ctx?) (= 80 port))))
+           (values t:from t:to)]
+          [ssl?
            (set-http-conn-port-usual?! hc (= 443 port))
            (cond
              [(osx-old-openssl?)
@@ -237,6 +245,52 @@
   (http-conn-open! hc host-bs #:ssl? ssl? #:port port)
   hc)
 
+(define (http-conn-CONNECT-tunnel proxy-host proxy-port target-host target-port #:ssl? [ssl? #f])
+  (define hc (http-conn-open proxy-host #:port proxy-port #:ssl? #f))
+  (define connect-string (format "~a:~a" target-host target-port))
+  ; (log-net/url-info "http-conn-CONNECT-tunnel tunnel to ~s for ~s" connect-string (url->string url))
+  (http-conn-send! hc #:method "CONNECT" connect-string #:headers
+                   (list (format "Host: ~a" connect-string)
+                         "Proxy-Connection: Keep-Alive"
+                         "Connection: Keep-Alive"))
+
+  (let ((tunnel-status (http-conn-status! hc))
+        (tunnel-headers (http-conn-headers! hc)))
+    (unless (regexp-match "^HTTP[^ ]* +2" tunnel-status)
+      (error 'make-ports "HTTP CONNECT failed: ~a" tunnel-status)))
+
+  ;; SSL secure the ports
+  (match-define (http-conn _ _ _ t:to t:from _) hc)
+  (cond [(not ssl?) ; it's just a tunnel... no ssl
+         (define abandon-p (lambda (p) ((http-conn-abandon-p hc) p)))
+         (values ssl? t:from t:to abandon-p)]
+
+        [else ; ssl
+          (define ssl-version (if (boolean? ssl?) 'auto ssl?))
+          (set-http-conn-port-usual?! hc (= 443 target-port))
+          ;; choose between win32 or non-win32 openssl here, then keep code common afterwards
+          (define-values (p->ssl-ps ssl-abndn-p)
+            (if (or ssl-available? (not win32-ssl-available?))
+              (values ports->ssl-ports ssl-abandon-port)
+              (values ports->win32-ssl-ports win32-ssl-abandon-port)))
+
+          (define clt-ctx
+            (match ssl-version
+                   [(? ssl-client-context? ctx) ctx]
+                   [(? symbol? protocol) (ssl-make-client-context protocol)]))
+
+          (define-values (r:from r:to) (p->ssl-ps t:from t:to
+                                                  #:mode 'connect
+                                                  #:context clt-ctx
+                                                  #:close-original? #t
+                                                  #:hostname target-host))
+
+          ;; The user of the tunnel relies on ports->ssl-ports' #:close-original? to close/abandon the
+          ;; underlying ports of the tunnel itself. Therefore the abandon-p sent back to caller is the
+          ;; ssl-abandon of the wrapped ports.
+          (define abandon-p ssl-abndn-p)
+          (values clt-ctx r:from r:to abandon-p)]))
+
 (define (head? method-bss)
   (or (equal? method-bss #"HEAD")
       (equal? method-bss "HEAD")
@@ -337,8 +391,17 @@
 (define data-procedure/c
   (-> (-> (or/c bytes? string?) void?) any))
 
+(define base-ssl?/c
+  (or/c boolean? ssl-client-context? symbol?))
+
+(define base-ssl?-tnl/c
+  (or/c base-ssl?/c (list/c base-ssl?/c input-port? output-port? (-> port? void?))))
+
 (provide
  data-procedure/c
+ base-ssl?/c
+ base-ssl?-tnl/c
+
  (contract-out
   [http-conn?
    (-> any/c
@@ -351,7 +414,7 @@
    (-> http-conn?)]
   [http-conn-open!
    (->* (http-conn? (or/c bytes? string?))
-        (#:ssl? (or/c boolean? ssl-client-context? symbol?)
+        (#:ssl? base-ssl?-tnl/c
                 #:port (between/c 1 65535))
         void?)]
   [http-conn-close!
@@ -371,9 +434,16 @@
   ;; Derived
   [http-conn-open
    (->* ((or/c bytes? string?))
-        (#:ssl? (or/c boolean? ssl-client-context? symbol?)
+        (#:ssl? base-ssl?-tnl/c
                 #:port (between/c 1 65535))
         http-conn?)]
+  [http-conn-CONNECT-tunnel
+    (->* ((or/c bytes? string?)
+          (between/c 1 65535)
+          (or/c bytes? string?)
+          (between/c 1 65535))
+         (#:ssl? base-ssl?/c)
+         (values base-ssl?/c input-port? output-port? (-> port? void?)))]
   [http-conn-recv!
    (->* (http-conn-live?)
         (#:content-decode (listof symbol?)
@@ -391,7 +461,7 @@
         (values bytes? (listof bytes?) input-port?))]
   [http-sendrecv
    (->* ((or/c bytes? string?) (or/c bytes? string?))
-        (#:ssl? (or/c boolean? ssl-client-context? symbol?)
+        (#:ssl? base-ssl?-tnl/c
                 #:port (between/c 1 65535)
                 #:version (or/c bytes? string?)
                 #:method (or/c bytes? string? symbol?)

racket/collects/net/url.rkt

@@ -5,6 +5,7 @@
          racket/list
          racket/match
          racket/promise
+         racket/tcp
          (prefix-in hc: "http-client.rkt")
          (only-in "url-connect.rkt" current-https-protocol)
          "uri-codec.rkt"
@@ -24,36 +25,51 @@
 ;;   "impure" = they have text waiting
 ;;   "pure" = the MIME headers have been read
 
-(define proxiable-url-schemes '("http"))
+(define proxiable-url-schemes '("http"
+                                "https"
+                                "git"))
 
-(define (env->c-p-s-entries envars)
+;; env->c-p-s-entries: (listof (listof string)) -> (listof (list string string num))
-  (if (null? envars)
+;;
+;; "http" protocol is proxied by http proxy
+;; other ("https" and "git") protocols are proxied by http CONNECT tunneling
+;;
+;; proxying-scheme is therefore always "http" (no "s") -- although the meaning thereof depends on the
+;; proxied-scheme
+(define (env->c-p-s-entries . envarses)
+  (define (inr envars)
+    (if (null? envars)
       null
+      (let ((proxied-scheme (match (car envars)
+                             [(regexp #rx"plt_(.*)_proxy" (list _ scm)) scm]
+                             [(regexp #rx"(.*)_proxy" (list _ scm)) scm])))
       (match (getenv (car envars))
-        [#f (env->c-p-s-entries (cdr envars))]
+             [#f (env->c-p-s-entries (cdr envars))]
-        ["" null]
+             ["" null]
-        [(app string->url
+             [(app string->url
-              (url (and scheme "http") #f (? string? host) (? integer? port)
+                   (url (and proxying-scheme "http") #f (? string? host) (? integer? port)
-                   _ (list) (list) #f))
+                        _ (list) (list) #f))
-         (list (list scheme host port))]
+              (list (list proxied-scheme host port))]
-        [(app string->url
+             [(app string->url
-              (url (and scheme "http") _ (? string? host) (? integer? port)
+                   (url (and proxying-scheme "http") _ (? string? host) (? integer? port)
-                   _ _ _ _))
+                        _ _ _ _))
-         (log-net/url-error "~s contains somewhat invalid proxy URL format" (car envars))
+              (log-net/url-warning "~s contains somewhat invalid proxy URL format" (car envars))
-         (list (list scheme host port))]
+              (list (list proxied-scheme host port))]
-        [inv (log-net/url-error "~s contained invalid proxy URL format: ~s"
+             [inv (log-net/url-error "~s contained invalid proxy URL format: ~s" (car envars) inv)
-                                (car envars) inv)
+                  null]))))
-             null])))
+  (apply append (map inr envarses)))
 
 (define current-proxy-servers-promise
-  (make-parameter (delay/sync (env->c-p-s-entries '("plt_http_proxy" "http_proxy")))))
+  (make-parameter (delay/sync (env->c-p-s-entries '("plt_http_proxy" "http_proxy")
+                                                  '("plt_https_proxy" "https_proxy")
+                                                  '("plt_git_proxy" "git_proxy")))))
 
 (define (proxy-servers-guard v)
   (unless (and (list? v)
                (andmap (lambda (v)
                          (and (list? v)
                               (= 3 (length v))
-                              (equal? (car v) "http")
+                              (member (car v) proxiable-url-schemes)
                               (string? (car v))
                               (exact-integer? (caddr v))
                               (<= 1 (caddr v) 65535)))
@@ -82,7 +98,8 @@
         [hostnames (string-split hostnames ",")])))
   
 (define current-no-proxy-servers-promise
-  (make-parameter (delay/sync (no-proxy-servers-guard (env->n-p-s-entries '("plt_no_proxy" "no_proxy"))))))
+  (make-parameter (delay/sync (no-proxy-servers-guard
+                                (env->n-p-s-entries '("plt_no_proxy" "no_proxy"))))))
 
 (define (no-proxy-servers-guard v)
   (unless (and (list? v)
@@ -111,6 +128,10 @@
           [(memf (lambda (np) (regexp-match np dest-host-name)) (current-no-proxy-servers)) #f]
           [else rv])))
 
+;; proxy-tunneled? : url -> boolean
+(define (proxy-tunneled? url)
+  (not (string=? (url-scheme url) "http")))
+
 (define (url-error fmt . args)
   (raise (make-url-exception
           (apply format fmt
@@ -129,15 +150,37 @@
 
 ;; make-ports : url -> hc
 (define (make-ports url proxy)
-  (let ([port-number (if proxy
+  (cond
-                       (caddr proxy)
+    [(not proxy)
-                       (or (url-port url) (url->default-port url)))]
+     (let ([target-port-number (or (url-port url) (url->default-port url))]
-        [host (if proxy (cadr proxy) (url-host url))])
+           [target-host (url-host url)])
-    (hc:http-conn-open host
+       (hc:http-conn-open target-host
-                       #:port port-number
+                          #:port target-port-number
-                       #:ssl? (if (equal? "https" (url-scheme url))
+                          #:ssl? (if (equal? "https" (url-scheme url))
-                                (current-https-protocol)
+                                   (current-https-protocol)
-                                #f))))
+                                   #f)))]
+    [(proxy-tunneled? url)
+     (let ([proxy-port-number (caddr proxy)]
+           [proxy-host (cadr proxy)])
+       (define-values (tnl:ssl? tnl:from-port tnl:to-port tnl:abandon-p)
+         (hc:http-conn-CONNECT-tunnel proxy-host
+                                      proxy-port-number
+                                      (url-host url)
+                                      (or (url-port url) (url->default-port url))
+                                      #:ssl? (if (equal? "https" (url-scheme url))
+                                               (current-https-protocol)
+                                               #f)))
+       (hc:http-conn-open (url-host url)
+                          #:port (or (url-port url) (url->default-port url))
+                          #:ssl? (list tnl:ssl? tnl:from-port tnl:to-port tnl:abandon-p)))]
+    [else 
+      (let ([proxy-port-number (caddr proxy)]
+            [proxy-host (cadr proxy)])
+        (hc:http-conn-open proxy-host
+                           #:port proxy-port-number
+                           #:ssl? (if (equal? "https" (url-scheme url))
+                                    (current-https-protocol)
+                                    #f)))]))
 
 ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str)
 ;;                               -> hc
@@ -148,7 +191,7 @@
   (define access-string
     (ensure-non-empty
      (url->string
-      (if proxy
+      (if (and proxy (not (proxy-tunneled? url)))
           url
           ;; RFCs 1945 and 2616 say:
           ;;   Note that the absolute path cannot be empty; if none is present in
@@ -398,7 +441,7 @@
          [access-string
           (ensure-non-empty
            (url->string
-            (if proxy
+            (if (and proxy (not (proxy-tunneled? url)))
                 url
                 (make-url #f #f #f #f
                           (url-path-absolute? url)
@@ -505,3 +548,18 @@
                   #:data (or/c false/c bytes? string? hc:data-procedure/c)
                   #:content-decode (listof symbol?))
         (values bytes? (listof bytes?) input-port?))]))
+
+;; tcp-or-tunnel-connect : string string number -> (values input-port? output-port?)
+(define (tcp-or-tunnel-connect scheme host port)
+  (match (proxy-server-for scheme host)
+         [(list _ proxy-host proxy-port)
+          (define-values (t:ssl-ctx t:from t:to t:abandon-p)
+            (hc:http-conn-CONNECT-tunnel proxy-host proxy-port host port #:ssl? #f))
+          (values t:from t:to)]
+         [_ (tcp-connect host port)]))
+
+(provide
+ (contract-out
+  [tcp-or-tunnel-connect
+   (-> string? string? (between/c 1 65535)
+       (values input-port? output-port?))]))