diff --git a/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl b/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl index 900c462951..6eaafd2d73 100644 --- a/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl +++ b/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl @@ -61,6 +61,13 @@ Closes @racket[hc] if it is live. } +@defproc[(http-conn-abandon! [hc http-conn?]) + void?]{ + +Closes the output side of @racket[hc], if it is live. + +} + @defproc[(http-conn-send! [hc http-conn-live?] [uri (or/c bytes? string?)] [#:version version (or/c bytes? string?) #"1.1"] [#:method method (or/c bytes? string? symbol?) #"GET"] diff --git a/pkgs/racket-pkgs/racket-test/tests/net/url-port.rkt b/pkgs/racket-pkgs/racket-test/tests/net/url-port.rkt index c5d31a5994..7b9e3143f1 100644 --- a/pkgs/racket-pkgs/racket-test/tests/net/url-port.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/net/url-port.rkt @@ -151,12 +151,14 @@ (module+ main (tests)) (define (tests) (test - (run-tests "http" values #f) - (run-tests "https" (let ([ctx (ssl-make-server-context)]) - (ssl-load-certificate-chain! ctx (collection-file-path "test.pem" "openssl")) - (ssl-load-private-key! ctx (collection-file-path "test.pem" "openssl")) - (lambda (in out) - (ports->ssl-ports in out #:mode 'accept #:context ctx))) - #t))) + (for ([i 100]) ; repeat to catch port leaks + (run-tests "http" values #f)) + (for ([i 100]) + (run-tests "https" (let ([ctx (ssl-make-server-context)]) + (ssl-load-certificate-chain! ctx (collection-file-path "test.pem" "openssl")) + (ssl-load-private-key! ctx (collection-file-path "test.pem" "openssl")) + (lambda (in out) + (ports->ssl-ports in out #:mode 'accept #:context ctx))) + #t)))) (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 a85ec137c9..fb93b38013 100644 --- a/racket/collects/net/http-client.rkt +++ b/racket/collects/net/http-client.rkt @@ -25,6 +25,8 @@ (define (regexp-member rx l) (ormap (λ (h) (regexp-match rx h)) l)) +(define PIPE-SIZE 4096) + ;; Core (struct http-conn (host to from abandon-p) #:mutable) @@ -65,10 +67,16 @@ (abandon to) (set-http-conn-to! hc #f)) (when from - ;; (abandon from) + (abandon from) (set-http-conn-from! hc #f)) (set-http-conn-abandon-p! hc #f)) +(define (http-conn-abandon! hc) + (match-define (http-conn host to from abandon) hc) + (when to + (abandon to) + (set-http-conn-to! hc #f))) + (define (http-conn-send! hc url-bs #:version [version-bs #"1.1"] #:method [method-bss #"GET"] @@ -90,7 +98,8 @@ (fprintf to "~a\r\n" h)) (fprintf to "\r\n") (when data - (display data to)) + (display data to) + (fprintf to "\r\n")) (flush-output to)) (define (http-conn-status! hc) @@ -114,7 +123,7 @@ (http-conn-response-port/length! hc +inf.0 #:close? #t)) (define (http-conn-response-port/length! hc count #:close? [close? #f]) - (define-values (in out) (make-pipe)) + (define-values (in out) (make-pipe PIPE-SIZE)) (thread (λ () (copy-bytes (http-conn-from hc) out count) @@ -145,7 +154,7 @@ (write-bytes bs op 0 chunk-size) (loop bs))))) - (define-values (in out) (make-pipe)) + (define-values (in out) (make-pipe PIPE-SIZE)) (thread (λ () (http-pipe-chunk (http-conn-from hc) out) @@ -168,6 +177,8 @@ (define close? (or iclose? (regexp-member #rx#"^(?i:Connection: +close)$" headers))) + (when close? + (http-conn-abandon! hc)) (define response-port (cond [(regexp-member #rx#"^(?i:Transfer-Encoding: +chunked)$" headers) @@ -232,6 +243,8 @@ void?)] [http-conn-close! (-> http-conn? void?)] + [http-conn-abandon! + (-> http-conn? void?)] [http-conn-send! (->* (http-conn-live? (or/c bytes? string?)) diff --git a/racket/collects/net/url.rkt b/racket/collects/net/url.rkt index a301de56a9..27ad0958b6 100644 --- a/racket/collects/net/url.rkt +++ b/racket/collects/net/url.rkt @@ -126,7 +126,7 @@ #f)))) ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) - ; -> hc +;; -> hc (define (http://getpost-impure-port get? url post-data strings make-ports 1.1?) (define proxy (assoc (url-scheme url) (current-proxy-servers))) @@ -202,8 +202,9 @@ [else (url-error "Scheme ~a unsupported" scheme)]))) (define (http-conn-impure-port hc) - (define-values (in out) (make-pipe)) - (define-values (status headers response-port) (hc:http-conn-recv! hc)) + (define-values (in out) (make-pipe 4096)) + (define-values (status headers response-port) + (hc:http-conn-recv! hc #:close? #t)) (fprintf out "~a\r\n" status) (for ([h (in-list headers)]) (fprintf out "~a\r\n" h)) @@ -237,7 +238,8 @@ (hc:http-conn-recv! (http://getpost-impure-port get? url post-data strings - make-ports #f))) + make-ports #f) + #:close? #t)) response-port] [else (define-values (port header) @@ -268,7 +270,7 @@ make-ports) (and conn #t))) (define-values (status headers response-port) - (hc:http-conn-recv! hc)) + (hc:http-conn-recv! hc #:close? (not conn))) (define new-url (ormap (λ (h)