From 321000b831a4acbc45c6645e6074f5b935d2eaa5 Mon Sep 17 00:00:00 2001 From: Tim Brown Date: Tue, 9 Aug 2016 12:50:17 +0100 Subject: [PATCH 1/6] https and git proxying via HTTP CONNECT MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 | 10 ++- racket/collects/net/http-client.rkt | 109 +++++++++++++++++++++++---- racket/collects/net/url.rkt | 104 +++++++++++++++++-------- 3 files changed, 177 insertions(+), 46 deletions(-) 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) From a5583485b67cff28edef92607574f1f9288b836c Mon Sep 17 00:00:00 2001 From: Tim Brown Date: Tue, 9 Aug 2016 14:12:04 +0100 Subject: [PATCH 2/6] PR#1411 Documentation --- .../net-doc/net/scribblings/http-client.scrbl | 53 +++++++++++++++++-- pkgs/net-doc/net/scribblings/url.scrbl | 30 +++++++---- 2 files changed, 71 insertions(+), 12 deletions(-) diff --git a/pkgs/net-doc/net/scribblings/http-client.scrbl b/pkgs/net-doc/net/scribblings/http-client.scrbl index 34d65d3ff5..6505dbf059 100644 --- a/pkgs/net-doc/net/scribblings/http-client.scrbl +++ b/pkgs/net-doc/net/scribblings/http-client.scrbl @@ -32,7 +32,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 +46,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 +138,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 +157,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 not provided then @racket[#f]. + + If it was a protocol symbol, then a new @racket[ssl-client-context] is created, otherwise the + current value of @racket[ssl?] is used as the @racket[ssl-client-context] to use. This client + context is negotiated with the SSL server and returned as the first value} + @item{An @racket[input-port?], which is connected to read from the tunnelled service} + @item{An @racket[output-port?], which is connected to write 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 +195,23 @@ 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?} diff --git a/pkgs/net-doc/net/scribblings/url.scrbl b/pkgs/net-doc/net/scribblings/url.scrbl index d6e402b455..9d18a1f64e 100644 --- a/pkgs/net-doc/net/scribblings/url.scrbl +++ b/pkgs/net-doc/net/scribblings/url.scrbl @@ -478,12 +478,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 +492,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 +500,28 @@ connections. Each mapping is a list of three elements: ] -The initial value of @racket[current-proxy-servers] is configured on demand from the -environment variables @indexed-envvar{plt_http_proxy} and @indexed-envvar{http_proxy}, -where the former takes precedence over the latter. +The initial value of @racket[current-proxy-servers] is configured on demand from environment +variables. Proxies for each URL scheme are configured from two variables each: + +@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, -an error will be logged to a @racket[net/url] logger. +@litchar{http://}@nonterm{hostname}@litchar{:}@nonterm{portno}. +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 From 14e1d13fe6400f6128f080186a68575cfcecc587 Mon Sep 17 00:00:00 2001 From: Tim Brown Date: Tue, 9 Aug 2016 14:30:50 +0100 Subject: [PATCH 3/6] PR#1411 documentation tippex --- .../net-doc/net/scribblings/http-client.scrbl | 22 +++++++++++-------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/pkgs/net-doc/net/scribblings/http-client.scrbl b/pkgs/net-doc/net/scribblings/http-client.scrbl index 6505dbf059..15c8e186ed 100644 --- a/pkgs/net-doc/net/scribblings/http-client.scrbl +++ b/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)) @@ -172,14 +174,14 @@ Creates an HTTP connection to @racket[proxy-host] (on port @racket[proxy-port]) The function returns four values: @itemize[ - @item{If @racket[ssl?] was not provided then @racket[#f]. - - If it was a protocol symbol, then a new @racket[ssl-client-context] is created, otherwise the - current value of @racket[ssl?] is used as the @racket[ssl-client-context] to use. This client - context is negotiated with the SSL server and returned as the first value} - @item{An @racket[input-port?], which is connected to read from the tunnelled service} - @item{An @racket[output-port?], which is connected to write to the tunnelled service} - @item{An abandon function, which when applied either returned, port will abandon it, in a manner + @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?] @@ -197,7 +199,8 @@ 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[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 @@ -209,6 +212,7 @@ argument, which is a string or byte string: 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?)))] } From 08c1865461b34d6d5b48f1320f0c80c98ae801af Mon Sep 17 00:00:00 2001 From: Tim Brown Date: Tue, 9 Aug 2016 15:37:29 +0100 Subject: [PATCH 4/6] PR#1411 Implementation for jeapsotrophe's comments See github commentary for rationale behind changes Also documentation for `tcp-or-tunnel-connect` --- pkgs/net-doc/net/scribblings/url.scrbl | 10 +++++++ racket/collects/net/git-checkout.rkt | 10 +------ racket/collects/net/http-client.rkt | 38 ++++++++++---------------- racket/collects/net/url.rkt | 16 +++++++++++ 4 files changed, 42 insertions(+), 32 deletions(-) diff --git a/pkgs/net-doc/net/scribblings/url.scrbl b/pkgs/net-doc/net/scribblings/url.scrbl index 9d18a1f64e..96a54259f1 100644 --- a/pkgs/net-doc/net/scribblings/url.scrbl +++ b/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) @@ -591,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] diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt index dc5bfa2126..00dd2b1b50 100644 --- a/racket/collects/net/git-checkout.rkt +++ b/racket/collects/net/git-checkout.rkt @@ -203,15 +203,7 @@ (define (initial-connect transport host verify? port repo status) (case transport [(git) - (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)))) + (define-values (i o) (tcp-or-tunnel-connect "git" 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 82198bc29b..ef793781a2 100644 --- a/racket/collects/net/http-client.rkt +++ b/racket/collects/net/http-client.rkt @@ -66,11 +66,11 @@ (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))] + (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 @@ -129,37 +129,34 @@ #: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) - (print-to "~a ~a HTTP/~a\r\n" method-bss url-bs version-bs) + (fprintf to "~a ~a HTTP/~a\r\n" method-bss url-bs version-bs) (unless (regexp-member #rx"^(?i:Host:) +.+$" headers-bs) - (print-to "Host: ~a\r\n" + (fprintf to "Host: ~a\r\n" (if port-usual? host (format "~a:~a" host port)))) (unless (regexp-member #rx"^(?i:User-Agent:) +.+$" headers-bs) - (print-to "User-Agent: Racket/~a (net/http-client)\r\n" + (fprintf 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)) - (print-to "Accept-Encoding: gzip\r\n")) + (fprintf to "Accept-Encoding: gzip\r\n")) (define body (->bytes data)) (cond [(procedure? body) - (print-to "Transfer-Encoding: chunked\r\n")] + (fprintf to "Transfer-Encoding: chunked\r\n")] [(and body (not (regexp-member #rx"^(?i:Content-Length:) +.+$" headers-bs))) - (print-to "Content-Length: ~a\r\n" (bytes-length body))]) + (fprintf to "Content-Length: ~a\r\n" (bytes-length body))]) (when close? (unless (regexp-member #rx"^(?i:Connection:) +.+$" headers-bs) - (print-to "Connection: close\r\n"))) + (fprintf to "Connection: close\r\n"))) (for ([h (in-list headers-bs)]) - (print-to "~a\r\n" h)) - (print-to "\r\n") + (fprintf to "~a\r\n" h)) + (fprintf to "\r\n") (cond [(procedure? body) (body (λ (data) (write-chunk to data))) - (print-to "0\r\n\r\n")] + (fprintf to "0\r\n\r\n")] [body (display body to)]) (flush-output to)) @@ -268,11 +265,6 @@ (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)) diff --git a/racket/collects/net/url.rkt b/racket/collects/net/url.rkt index eb9859cfab..3b393e2a70 100644 --- a/racket/collects/net/url.rkt +++ b/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" @@ -547,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?))])) From 7fb52529f8c9e6c348942c37cb2842af5fe12ab6 Mon Sep 17 00:00:00 2001 From: Tim Brown Date: Wed, 10 Aug 2016 16:08:16 +0100 Subject: [PATCH 5/6] PR#1411 Tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit http-proxy/ contains a suite of almost useful (but mostly useless) servers. These can be used to test http-client, and url.rkt git proxy is not tested yet -- I really wouldn’t know how --- pkgs/net-test/tests/net/http-client.rkt | 25 +++- .../tests/net/http-proxy/echo-server.rkt | 30 +++++ .../tests/net/http-proxy/generic-server.rkt | 38 ++++++ .../tests/net/http-proxy/https-non-server.rkt | 49 ++++++++ .../tests/net/http-proxy/proxy-server.rkt | 108 ++++++++++++++++++ pkgs/net-test/tests/net/url.rkt | 90 +++++++++++++-- racket/collects/net/http-client.rkt | 5 +- 7 files changed, 332 insertions(+), 13 deletions(-) create mode 100644 pkgs/net-test/tests/net/http-proxy/echo-server.rkt create mode 100644 pkgs/net-test/tests/net/http-proxy/generic-server.rkt create mode 100644 pkgs/net-test/tests/net/http-proxy/https-non-server.rkt create mode 100644 pkgs/net-test/tests/net/http-proxy/proxy-server.rkt diff --git a/pkgs/net-test/tests/net/http-client.rkt b/pkgs/net-test/tests/net/http-client.rkt index e493d88979..ae52e90264 100644 --- a/pkgs/net-test/tests/net/http-client.rkt +++ b/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)) diff --git a/pkgs/net-test/tests/net/http-proxy/echo-server.rkt b/pkgs/net-test/tests/net/http-proxy/echo-server.rkt new file mode 100644 index 0000000000..42550aa636 --- /dev/null +++ b/pkgs/net-test/tests/net/http-proxy/echo-server.rkt @@ -0,0 +1,30 @@ +#lang racket/base +; An echo server -- ripped off the racket homepage +(provide server current-listen-port) + +(require racket/port "generic-server.rkt") + +(define (server) + (serve (lambda (i o) (copy-port i o)))) + +(module+ + main + (define-values (server-thread shutdown-server) (server)) + (thread-wait server-thread)) + +(module+ + test + (require rackunit racket/tcp) + (define-values (server-thread shutdown-server) (server)) + + (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) + (sleep 5) + (shutdown-server)) diff --git a/pkgs/net-test/tests/net/http-proxy/generic-server.rkt b/pkgs/net-test/tests/net/http-proxy/generic-server.rkt new file mode 100644 index 0000000000..967f49a09b --- /dev/null +++ b/pkgs/net-test/tests/net/http-proxy/generic-server.rkt @@ -0,0 +1,38 @@ +#lang racket/base +;; with thanks to "More: Systems Programming with Racket" +(provide serve current-listen-port) + +(require racket/tcp) + +(define current-listen-port (make-parameter 12345)) + +(define (accept-and-handle listener handler) + (define cust (make-custodian)) + (define handler-thread + (parameterize ([current-custodian cust]) + (define-values (in out) (tcp-accept listener)) + (file-stream-buffer-mode in 'none) + (file-stream-buffer-mode out 'none) + (thread (lambda () + (handler in out) + (close-output-port out) + (close-input-port in))))) + (thread (lambda () + (thread-wait handler-thread) + (custodian-shutdown-all cust)))) + +(define (serve handler) + (define serving-sem (make-semaphore)) + (define main-cust (make-custodian)) + (define server-thread + (parameterize ([current-custodian main-cust]) + (define listener (tcp-listen (current-listen-port) 5 #t)) + (semaphore-post serving-sem) ; listening... so caller is ready to continue + (define (loop) + (accept-and-handle listener handler) + (loop)) + (thread loop))) + (values server-thread (lambda () (custodian-shutdown-all main-cust)))) + +;; tested via the echo-server (in this directory) +;; (module+ test) diff --git a/pkgs/net-test/tests/net/http-proxy/https-non-server.rkt b/pkgs/net-test/tests/net/http-proxy/https-non-server.rkt new file mode 100644 index 0000000000..e441b27d72 --- /dev/null +++ b/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) + +(require racket/match + racket/port + openssl + syntax/modresolve + "generic-server.rkt") + +(define (server) + (serve + (lambda (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")])))) + +(module+ + main + (define-values (server-thread shutdown-server) (server)) + (thread-wait server-thread)) + +(module+ test) diff --git a/pkgs/net-test/tests/net/http-proxy/proxy-server.rkt b/pkgs/net-test/tests/net/http-proxy/proxy-server.rkt new file mode 100644 index 0000000000..855c38f4ed --- /dev/null +++ b/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) + +(define serving-sem (make-semaphore)) + +(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!$")) + + ) diff --git a/pkgs/net-test/tests/net/url.rkt b/pkgs/net-test/tests/net/url.rkt index 89c602ce29..d1c52bb0e9 100644 --- a/pkgs/net-test/tests/net/url.rkt +++ b/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) - (put! "http_proxy" http-proxy) - (put! "plt_no_proxy" plt-no-proxy) - (put! "no_proxy" no-proxy) + (for ((var.val (in-list `(("plt_http_proxy" . ,plt-http-proxy) + ("plt_https_proxy" . ,plt-https-proxy) + ("plt_git_proxy" . ,plt-git-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 diff --git a/racket/collects/net/http-client.rkt b/racket/collects/net/http-client.rkt index ef793781a2..27abbb3aad 100644 --- a/racket/collects/net/http-client.rkt +++ b/racket/collects/net/http-client.rkt @@ -288,10 +288,7 @@ ;; 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))) - + (define abandon-p ssl-abndn-p) (values clt-ctx r:from r:to abandon-p)])) (define (http-conn-recv! hc From 9da549ea87e56f73b84b6994bc938a5d23eb5064 Mon Sep 17 00:00:00 2001 From: Tim Brown Date: Mon, 15 Aug 2016 10:27:07 +0100 Subject: [PATCH 6/6] PR1411 Jays observations re thread-server --- .../tests/net/http-proxy/echo-server.rkt | 41 ++++++----- .../tests/net/http-proxy/generic-server.rkt | 55 +++++++-------- .../tests/net/http-proxy/https-non-server.rkt | 68 +++++++++---------- .../tests/net/http-proxy/proxy-server.rkt | 6 +- 4 files changed, 86 insertions(+), 84 deletions(-) diff --git a/pkgs/net-test/tests/net/http-proxy/echo-server.rkt b/pkgs/net-test/tests/net/http-proxy/echo-server.rkt index 42550aa636..7fef5a9739 100644 --- a/pkgs/net-test/tests/net/http-proxy/echo-server.rkt +++ b/pkgs/net-test/tests/net/http-proxy/echo-server.rkt @@ -1,30 +1,35 @@ #lang racket/base -; An echo server -- ripped off the racket homepage -(provide server current-listen-port) +(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)) - (thread-wait server-thread)) + (dynamic-wind + void + (λ () (thread-wait server-thread)) + shutdown-server)) (module+ - test - (require rackunit racket/tcp) - (define-values (server-thread shutdown-server) (server)) - - (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) - (sleep 5) - (shutdown-server)) + 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)) \ No newline at end of file diff --git a/pkgs/net-test/tests/net/http-proxy/generic-server.rkt b/pkgs/net-test/tests/net/http-proxy/generic-server.rkt index 967f49a09b..cdc8879b11 100644 --- a/pkgs/net-test/tests/net/http-proxy/generic-server.rkt +++ b/pkgs/net-test/tests/net/http-proxy/generic-server.rkt @@ -1,38 +1,35 @@ #lang racket/base -;; with thanks to "More: Systems Programming with Racket" -(provide serve current-listen-port) +(provide serve + current-listen-port + current-conn-timeout) -(require racket/tcp) +(require mzlib/thread + racket/tcp) (define current-listen-port (make-parameter 12345)) -(define (accept-and-handle listener handler) - (define cust (make-custodian)) - (define handler-thread - (parameterize ([current-custodian cust]) - (define-values (in out) (tcp-accept listener)) - (file-stream-buffer-mode in 'none) - (file-stream-buffer-mode out 'none) - (thread (lambda () - (handler in out) - (close-output-port out) - (close-input-port in))))) - (thread (lambda () - (thread-wait handler-thread) - (custodian-shutdown-all cust)))) +(define current-conn-timeout (make-parameter #f)) -(define (serve handler) - (define serving-sem (make-semaphore)) - (define main-cust (make-custodian)) - (define server-thread - (parameterize ([current-custodian main-cust]) - (define listener (tcp-listen (current-listen-port) 5 #t)) - (semaphore-post serving-sem) ; listening... so caller is ready to continue - (define (loop) - (accept-and-handle listener handler) - (loop)) - (thread loop))) - (values server-thread (lambda () (custodian-shutdown-all main-cust)))) +(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) diff --git a/pkgs/net-test/tests/net/http-proxy/https-non-server.rkt b/pkgs/net-test/tests/net/http-proxy/https-non-server.rkt index e441b27d72..f262fb2b9b 100644 --- a/pkgs/net-test/tests/net/http-proxy/https-non-server.rkt +++ b/pkgs/net-test/tests/net/http-proxy/https-non-server.rkt @@ -1,49 +1,49 @@ #lang racket/base ; It may look like an HTTPS server, but it very isn’t -(provide server current-listen-port) +(provide server + current-listen-port + current-conn-timeout) (require racket/match - racket/port openssl syntax/modresolve "generic-server.rkt") -(define (server) - (serve - (lambda (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))) +(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")])) - (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)) - (thread-wait server-thread)) + (dynamic-wind void (λ () (thread-wait server-thread)) shutdown-server)) (module+ test) diff --git a/pkgs/net-test/tests/net/http-proxy/proxy-server.rkt b/pkgs/net-test/tests/net/http-proxy/proxy-server.rkt index 855c38f4ed..f2c051c0a1 100644 --- a/pkgs/net-test/tests/net/http-proxy/proxy-server.rkt +++ b/pkgs/net-test/tests/net/http-proxy/proxy-server.rkt @@ -3,9 +3,9 @@ ;; 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) - -(define serving-sem (make-semaphore)) +(provide server + current-listen-port + current-conn-timeout) (define (http-tunnel-serve in out) (let/ec