diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt index 6ebc1caa75..dc5bfa2126 100644 --- a/racket/collects/net/git-checkout.rkt +++ b/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 diff --git a/racket/collects/net/http-client.rkt b/racket/collects/net/http-client.rkt index 381e4bb913..82198bc29b 100644 --- a/racket/collects/net/http-client.rkt +++ b/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)) - (fprintf to "\r\n") + (print-to "~a\r\n" h)) + (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?) diff --git a/racket/collects/net/url.rkt b/racket/collects/net/url.rkt index 2a18b5db7a..eb9859cfab 100644 --- a/racket/collects/net/url.rkt +++ b/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) - (if (null? 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) - _ (list) (list) #f)) - (list (list scheme host port))] - [(app string->url - (url (and scheme "http") _ (? string? host) (? integer? port) - _ _ _ _)) - (log-net/url-error "~s contains somewhat invalid proxy URL format" (car envars)) - (list (list scheme host port))] - [inv (log-net/url-error "~s contained invalid proxy URL format: ~s" - (car envars) inv) - null]))) + [#f (env->c-p-s-entries (cdr envars))] + ["" null] + [(app string->url + (url (and proxying-scheme "http") #f (? string? host) (? integer? port) + _ (list) (list) #f)) + (list (list proxied-scheme host port))] + [(app string->url + (url (and proxying-scheme "http") _ (? string? host) (? integer? port) + _ _ _ _)) + (log-net/url-warning "~s contains somewhat invalid proxy URL format" (car envars)) + (list (list proxied-scheme host port))] + [inv (log-net/url-error "~s contained invalid proxy URL format: ~s" (car envars) inv) + 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 - (caddr proxy) - (or (url-port url) (url->default-port url)))] - [host (if proxy (cadr proxy) (url-host url))]) - (hc:http-conn-open host - #:port port-number - #:ssl? (if (equal? "https" (url-scheme url)) - (current-https-protocol) - #f)))) + (cond + [(not proxy) + (let ([target-port-number (or (url-port url) (url->default-port url))] + [target-host (url-host url)]) + (hc:http-conn-open target-host + #:port target-port-number + #:ssl? (if (equal? "https" (url-scheme url)) + (current-https-protocol) + #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)