suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
https and git proxying via HTTP CONNECT
This commit is contained in:
Jay McCarthy 2016-08-18 11:16:48 -04:00 committed by GitHub
commit de3faeeda4
11 changed files with 582 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
pkgs/net-doc/net/scribblings/http-client.scrbl
View File

@ -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?}

40
pkgs/net-doc/net/scribblings/url.scrbl
View File

@ -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
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
@ -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]

25
pkgs/net-test/tests/net/http-client.rkt
View File

@ -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))

35
pkgs/net-test/tests/net/http-proxy/echo-server.rkt Normal file
View File

@ -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))

35
pkgs/net-test/tests/net/http-proxy/generic-server.rkt Normal file
View File

@ -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)

49
pkgs/net-test/tests/net/http-proxy/https-non-server.rkt Normal file
View File

@ -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)

108
pkgs/net-test/tests/net/http-proxy/proxy-server.rkt Normal file
View File

@ -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!$"))
)

88
pkgs/net-test/tests/net/url.rkt
View File

@ -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)])
@ -41,11 +54,15 @@
(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

2
racket/collects/net/git-checkout.rkt
View File

@ -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

78
racket/collects/net/http-client.rkt
View File

@ -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?)

120
racket/collects/net/url.rkt
View File

@ -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)
(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 +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
(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 +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?))]))