PR#1411 Tests
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
This commit is contained in:
Tim Brown
parent
08c1865461
commit
7fb52529f8
|
|
@ -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))
|
||||
|
|
|
|||
30
pkgs/net-test/tests/net/http-proxy/echo-server.rkt
Normal file
30
pkgs/net-test/tests/net/http-proxy/echo-server.rkt
Normal file
|
|
@ -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))
|
||||
38
pkgs/net-test/tests/net/http-proxy/generic-server.rkt
Normal file
38
pkgs/net-test/tests/net/http-proxy/generic-server.rkt
Normal file
|
|
@ -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)
|
||||
49
pkgs/net-test/tests/net/http-proxy/https-non-server.rkt
Normal file
49
pkgs/net-test/tests/net/http-proxy/https-non-server.rkt
Normal 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)
|
||||
|
||||
(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)
|
||||
108
pkgs/net-test/tests/net/http-proxy/proxy-server.rkt
Normal file
108
pkgs/net-test/tests/net/http-proxy/proxy-server.rkt
Normal 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)
|
||||
|
||||
(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!$"))
|
||||
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user