https and git proxying via HTTP CONNECT

This patch adds https and git proxying through HTTP’s `CONNECT` method.

**Sanity Checks Needed:**
1. Is the git protocol proxying necessary?
   It might be overkill, and I haven’t overly tested it since `raco pkg
   install` uses https as its transport anyway
2. If anyone is better clued up on HTTP `CONNECT` best practice, then
   please check the headers that I pass (in `http-client.rkt`)
3. Is HTTP `CONNECT` the only/best way to proxy HTTPS? It is what *curl*
   uses (which might be a good indicator)
4. Will the ports be closed properly? (does anyone see a fid leak?)
  - how do I test for that? Open (and allegedly close) 1024 tunnels?
5. The `abandon-p` definitions in `http-conn-CONNECT-tunnel` could
   probably be reduced, but they’re defined as they are to allow me to
   put debugging hooks in
6. No tests or documentation yet
7. I edited this with *vim*, and therefore the indentation is a la vim.
   I looked at doing a global reindent (of git-checkout) and so much
   changed that I abandoned that as an idea. It indentation is too
   “off-style” then feel free to change it :-)

**git-checkout.rkt:**
- `initial-connect` now tries to use a git proxy (see `url.rkt`, below)
  when *transport*=`git`
- (if *transport*=`https`, then `url.rkt`’s standard proxying will be
  used)

**http-client.rkt:**
- `http-conn-open!` can now be passed a
  `(list/c base-ssl?/c input-port? output-port? (-> port? void?))` to
  describe:
  - maybe a negotiated ssl context
  - two tunnel (or other arbitrary) ports to use instead of newly
    `...-connect`ed ports
  - an abandon function for those ports
- `http-conn-send!` has a function `print-to` which curries
  `(fprintf to)`, but allows a hook for an `eprintf` for debugging
- **added `http-conn-CONNECT-tunnel`:** this opens an new `http-conn`
  and arranges for CONNECT tunneling to `target-host` and `target-port`
- factored contracts into `base-ssl?/c` and `base-ssl?-tnl/c`
- added contract for `http-conn-CONNECT-tunnel`

**url.rkt:**
- `proxiable-url-schemes`: now includes `https` and `git`
- `env->c-p-s-entries`: the environment variable “parser” now takes a
  rest-list of lists of environment variables, and the scheme that these
  variables proxy is garnered from the variables’ names. As before
  there are:
  - `plt_http_proxy` and `http_proxy`
  - `plt_https_proxy` and `https_proxy`
  - `plt_git_proxy` and `git_proxy`
  during the previous iteration of obtaining the proxy variables at
  startup, we discussed the appropriate naming conventions for these
  variables. This doesn’t seem to deviate from that
- `env->c-p-s-entries`: having a proxy url that isn’t strictly:
  `http://hostname:portno` (e.g.  having a training slash) generates a
  log warning, not an error. It was beginning to bug me
- `proxy-servers-guard`: accepts any one of the `proxiable-url-schemes`
  (not just `http`)
- no proxy is agnostic to the URL scheme
- `proxy-tunneled?`: returns false for `http`, which is proxied using an
  HTTP proxy. Returns true for other URL schemes -- which go through a
  tunnel
- **`make-ports`:** tests whether a tunnel proxy is necessary. If so, it
  creates a tunnel and plumbs the connections
- elsewhere, anywhere that tests for proxy, now tests for
  `(and proxy (not proxy-tunneled? url))`, because tunneled HTTPS
  connections are direct (once they’re through the tunnel, IYSWIM)

racket/collects/net/git-checkout.rkt

@@ -203,7 +203,15 @@
 (define (initial-connect transport host verify? port repo status)
   (case transport
     [(git)
-     (define-values (i o) (tcp-connect host port))
+     (define-values (i o)
+       (let ((proxy (proxy-server-for "git" host)))
+         (if proxy
+           (let ((proxy-host (cadr proxy))
+                 (proxy-port (caddr proxy)))
+             (let-values (([t:ssl-ctx t:from t:to t:abandon-p]
+                           (http-conn-CONNECT-tunnel proxy-host proxy-port host port #:ssl? #f)))
+               (values t:from t:to)))
+           (tcp-connect 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-let (((list ssl? (? 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? (= 443 port))
+                                                (and (not ssl?) (= 80 port))))
+             (values t:from t:to))]
+          [ssl?
            (set-http-conn-port-usual?! hc (= 443 port))
            (cond
              [(osx-old-openssl?)
@@ -121,34 +129,37 @@
                          #:headers [headers-bs empty]
                          #:content-decode [decodes '(gzip)]
                          #:data [data #f])
+  (define (print-to fmt . args)
+    ;; (eprintf "print-to: ~a~%" (apply format fmt args))
+    (apply fprintf to fmt args))
   (match-define (http-conn host port port-usual? to from _) hc)
-  (fprintf to "~a ~a HTTP/~a\r\n" method-bss url-bs version-bs)
+  (print-to "~a ~a HTTP/~a\r\n" method-bss url-bs version-bs)
   (unless (regexp-member #rx"^(?i:Host:) +.+$" headers-bs)
-    (fprintf to "Host: ~a\r\n" 
+    (print-to "Host: ~a\r\n" 
              (if port-usual?
                host
                (format "~a:~a" host port))))
   (unless (regexp-member #rx"^(?i:User-Agent:) +.+$" headers-bs)
-    (fprintf to "User-Agent: Racket/~a (net/http-client)\r\n" 
+    (print-to "User-Agent: Racket/~a (net/http-client)\r\n" 
              (version)))
   (unless (or (not (memq 'gzip decodes))
               (regexp-member #rx"^(?i:Accept-Encoding:) +.+$" headers-bs))
-    (fprintf to "Accept-Encoding: gzip\r\n"))
+    (print-to "Accept-Encoding: gzip\r\n"))
   (define body (->bytes data))
   (cond [(procedure? body)
-         (fprintf to "Transfer-Encoding: chunked\r\n")]
+         (print-to "Transfer-Encoding: chunked\r\n")]
         [(and body
               (not (regexp-member #rx"^(?i:Content-Length:) +.+$" headers-bs)))
-         (fprintf to "Content-Length: ~a\r\n" (bytes-length body))])
+         (print-to "Content-Length: ~a\r\n" (bytes-length body))])
   (when close?
     (unless (regexp-member #rx"^(?i:Connection:) +.+$" headers-bs)
-      (fprintf to "Connection: close\r\n")))
+      (print-to "Connection: close\r\n")))
   (for ([h (in-list headers-bs)])
-    (fprintf to "~a\r\n" h))
+    (print-to "~a\r\n" h))
-  (fprintf to "\r\n")
+  (print-to "\r\n")
   (cond [(procedure? body)
          (body (λ (data) (write-chunk to data)))
-         (fprintf to "0\r\n\r\n")]
+         (print-to "0\r\n\r\n")]
         [body (display body to)])
   (flush-output to))
 
@@ -237,6 +248,60 @@
   (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)]
+
+        [(osx-old-openssl?)
+         (http-conn-close! hc)
+         ;; osx-old-openssl? doesn't support ports->...ssl-ports
+         (error 'http-conn-open! "osx-old-openssl? does not support a ports->...ssl-ports function")]
+
+        [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 (lambda (p)
+                              ;; which should abandon the original ports, too
+                              (ssl-abndn-p p)))
+
+          (values clt-ctx r:from r:to abandon-p)]))
+
 (define (http-conn-recv! hc
                          #:method [method-bss #"GET"]
                          #:content-decode [decodes '(gzip)]
@@ -334,8 +399,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
@@ -348,7 +422,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!
@@ -368,9 +442,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?)
@@ -388,7 +469,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

@@ -24,36 +24,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))
+;;
+;; "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))]
              ["" null]
              [(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 scheme host port))]
+              (list (list proxied-scheme host port))]
              [(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 +97,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 +127,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 +149,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))
                                    (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 +190,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 +440,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)