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