net/url: fix problems with new implementation on net/http-client

Various `net/url` operations need to request a close of the
connection after the operation completes, and `het/http-client`
needs to actually close the input-port half of a connection.

Also, add `http-conn-abandon!`.

Also also, add limits on internal pipes, so that data doesn't pile
up in a connection-processing thread, and fix POST/PUT by adding
a needed CRLF after posted data.
This commit is contained in:
Matthew Flatt 2013-08-30 10:37:09 -06:00
parent 701aa9ce0a
commit 0dcaa5e19f
4 changed files with 40 additions and 16 deletions

View File

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

View File

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

View File

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

View File

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