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:
parent
701aa9ce0a
commit
0dcaa5e19f
|
@ -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"]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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?))
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user