Fixing pr11125
This commit is contained in:
Jay McCarthy
parent
d4e3946ba2
commit
7190d423f7
66
collects/tests/web-server/pr/11125.rkt
Normal file
66
collects/tests/web-server/pr/11125.rkt
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
#lang racket
|
||||
(require net/url
|
||||
web-server/http
|
||||
web-server/http/request
|
||||
web-server/servlet-env
|
||||
tests/eli-tester)
|
||||
|
||||
(define PORT 8999)
|
||||
|
||||
(define (do-the-test PORT #:connection-close? connection-close?)
|
||||
(define tc (make-thread-cell 0))
|
||||
|
||||
(define (start req)
|
||||
(thread-cell-set! tc (add1 (thread-cell-ref tc)))
|
||||
(number->string (thread-cell-ref tc)))
|
||||
|
||||
(define-values (pipe-read-p pipe-write-p)
|
||||
(make-pipe))
|
||||
|
||||
(define server-t
|
||||
(thread
|
||||
(λ ()
|
||||
(parameterize ([current-output-port pipe-write-p])
|
||||
(serve/servlet start
|
||||
#:launch-browser? #f
|
||||
#:connection-close? connection-close?
|
||||
#:quit? #f
|
||||
#:listen-ip #f
|
||||
#:port PORT
|
||||
#:servlet-path "/")))))
|
||||
|
||||
; Wait for server to start
|
||||
(void (read-line pipe-read-p)
|
||||
(read-line pipe-read-p))
|
||||
|
||||
(define-values (http-read-p http-write-p)
|
||||
(tcp-connect "localhost" PORT))
|
||||
|
||||
(define (get-tc/err http-read-p http-write-p)
|
||||
(with-handlers
|
||||
([exn?
|
||||
(λ (x)
|
||||
(define-values (new-http-read-p new-http-write-p)
|
||||
(tcp-connect "localhost" PORT))
|
||||
(set! http-read-p new-http-read-p)
|
||||
(set! http-write-p new-http-write-p)
|
||||
(get-tc http-read-p http-write-p))])
|
||||
(get-tc http-read-p http-write-p)))
|
||||
|
||||
(define (get-tc http-read-p http-write-p)
|
||||
(fprintf http-write-p "GET / HTTP/1.1\r\n\r\n")
|
||||
(flush-output http-write-p)
|
||||
|
||||
(read-line http-read-p)
|
||||
(read-headers http-read-p)
|
||||
(string->number (string (read-char http-read-p))))
|
||||
|
||||
(begin0
|
||||
(list (get-tc/err http-read-p http-write-p)
|
||||
(get-tc/err http-read-p http-write-p))
|
||||
|
||||
(kill-thread server-t)))
|
||||
|
||||
(test
|
||||
(do-the-test PORT #:connection-close? #f) => (list 1 2)
|
||||
(do-the-test (add1 PORT) #:connection-close? #t) => (list 1 1))
|
||||
|
|
@ -6,26 +6,27 @@
|
|||
web-server/private/connection-manager
|
||||
web-server/http/request-structs)
|
||||
|
||||
(define read-request/c
|
||||
(connection?
|
||||
tcp-listen-port?
|
||||
(input-port? . -> . (values string? string?))
|
||||
. -> .
|
||||
(values request? boolean?)))
|
||||
|
||||
(provide/contract
|
||||
[read-headers (-> input-port? (listof header?))]
|
||||
[rename make-ext:read-request make-read-request
|
||||
(->* () (#:connection-close? boolean?) read-request/c)]
|
||||
[rename ext:read-request read-request
|
||||
(connection?
|
||||
tcp-listen-port?
|
||||
(input-port? . -> . (values string? string?))
|
||||
. -> .
|
||||
(values request? boolean?))])
|
||||
|
||||
(define (ext:read-request conn host-port port-addresses)
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(kill-connection! conn)
|
||||
(raise exn))])
|
||||
(read-request conn host-port port-addresses)))
|
||||
read-request/c])
|
||||
|
||||
;; **************************************************
|
||||
;; read-request: connection number (input-port -> string string) -> request boolean?
|
||||
;; read the request line, and the headers, determine if the connection should
|
||||
;; be closed after servicing the request and build a request structure
|
||||
(define (read-request conn host-port port-addresses)
|
||||
(define ((make-read-request
|
||||
#:connection-close? [connection-close? #f])
|
||||
conn host-port port-addresses)
|
||||
(define ip
|
||||
(connection-i-port conn))
|
||||
(define-values (method uri major minor)
|
||||
|
|
@ -46,8 +47,23 @@
|
|||
(values
|
||||
(make-request method uri headers bindings/raw-promise raw-post-data
|
||||
host-ip host-port client-ip)
|
||||
(close-connection? headers major minor
|
||||
client-ip host-ip)))
|
||||
(or connection-close?
|
||||
(close-connection? headers major minor
|
||||
client-ip host-ip))))
|
||||
|
||||
(define (make-ext:read-request
|
||||
#:connection-close? [connection-close? #f])
|
||||
(define read-request
|
||||
(make-read-request #:connection-close? connection-close?))
|
||||
(define (ext:read-request conn host-port port-addresses)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(kill-connection! conn)
|
||||
(raise exn))])
|
||||
(read-request conn host-port port-addresses)))
|
||||
ext:read-request)
|
||||
|
||||
(define ext:read-request (make-ext:read-request #:connection-close? #f))
|
||||
|
||||
;; **************************************************
|
||||
;; close-connection?
|
||||
|
|
@ -153,14 +169,14 @@
|
|||
(cond
|
||||
[(bytes-ci=? #"GET" meth)
|
||||
(values (delay
|
||||
(filter (lambda (x) x)
|
||||
(map (match-lambda
|
||||
[(list-rest k v)
|
||||
(if (and (symbol? k) (string? v))
|
||||
(make-binding:form (string->bytes/utf-8 (symbol->string k))
|
||||
(string->bytes/utf-8 v))
|
||||
#f)])
|
||||
(url-query uri))))
|
||||
(filter (lambda (x) x)
|
||||
(map (match-lambda
|
||||
[(list-rest k v)
|
||||
(if (and (symbol? k) (string? v))
|
||||
(make-binding:form (string->bytes/utf-8 (symbol->string k))
|
||||
(string->bytes/utf-8 v))
|
||||
#f)])
|
||||
(url-query uri))))
|
||||
#f)]
|
||||
[(bytes-ci=? #"POST" meth)
|
||||
(local
|
||||
|
|
@ -174,17 +190,17 @@
|
|||
; I think this is reasonable because the Content-Type said it would have this format
|
||||
(define bs
|
||||
(map (match-lambda
|
||||
[(struct mime-part (headers contents))
|
||||
(define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
|
||||
(match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
|
||||
(regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
|
||||
[(list #f #f)
|
||||
(network-error 'reading-bindings "Couldn't extract form field name for file upload")]
|
||||
[(list #f (list _ _ f0 f1))
|
||||
(make-binding:form (or f0 f1) (apply bytes-append contents))]
|
||||
[(list (list _ _ f00 f01) (list _ _ f10 f11))
|
||||
(make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
|
||||
(read-mime-multipart content-boundary in)))
|
||||
[(struct mime-part (headers contents))
|
||||
(define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
|
||||
(match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
|
||||
(regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
|
||||
[(list #f #f)
|
||||
(network-error 'reading-bindings "Couldn't extract form field name for file upload")]
|
||||
[(list #f (list _ _ f0 f1))
|
||||
(make-binding:form (or f0 f1) (apply bytes-append contents))]
|
||||
[(list (list _ _ f00 f01) (list _ _ f10 f11))
|
||||
(make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
|
||||
(read-mime-multipart content-boundary in)))
|
||||
(values
|
||||
(delay bs)
|
||||
#f)])]
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ This module provides functions for launching dispatching servers.
|
|||
|
||||
@defproc[(serve [#:dispatch dispatch dispatcher/c]
|
||||
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
|
||||
[#:connection-close? connection-close? boolean? #f]
|
||||
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
|
||||
[#:port port tcp-listen-port? 80]
|
||||
[#:listen-ip listen-ip (or/c string? false/c) #f]
|
||||
|
|
@ -31,6 +32,9 @@ This module provides functions for launching dispatching servers.
|
|||
Constructs an appropriate @racket[dispatch-server-config^], invokes the
|
||||
@racket[dispatch-server@], and calls its @racket[serve] function.
|
||||
|
||||
If @racket[connection-close?] is @racket[#t], then every connection is closed after one
|
||||
request. Otherwise, the client decides based on what HTTP version it uses.
|
||||
|
||||
The @racket[#:tcp@] keyword is provided for building an SSL server. See @secref["faq:https"].
|
||||
}
|
||||
|
||||
|
|
@ -51,6 +55,7 @@ from a given path:
|
|||
|
||||
@defproc[(serve/ports [#:dispatch dispatch dispatcher/c]
|
||||
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
|
||||
[#:connection-close? connection-close? boolean? #f]
|
||||
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
|
||||
[#:ports ports (listof tcp-listen-port?) (list 80)]
|
||||
[#:listen-ip listen-ip (or/c string? false/c) #f]
|
||||
|
|
@ -63,6 +68,7 @@ from a given path:
|
|||
|
||||
@defproc[(serve/ips+ports [#:dispatch dispatch dispatcher/c]
|
||||
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
|
||||
[#:connection-close? connection-close? boolean? #f]
|
||||
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
|
||||
[#:ips+ports ips+ports (listof (cons/c (or/c string? false/c) (listof tcp-listen-port?))) (list (cons #f (list 80)))]
|
||||
[#:max-waiting max-waiting integer? 40]
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ These functions optimize the construction of dispatchers and launching of server
|
|||
|
||||
@defproc[(serve/launch/wait
|
||||
[make-dispatcher (semaphore? . -> . dispatcher/c)]
|
||||
[#:connection-close? connection-close? boolean? #f]
|
||||
[#:launch-path launch-path (or/c false/c string?) #f]
|
||||
[#:banner? banner? boolean? #f]
|
||||
[#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"]
|
||||
|
|
@ -67,9 +68,11 @@ These functions optimize the construction of dispatchers and launching of server
|
|||
connections to all of the listening machine's addresses. Otherwise, the server accepts connections only at the interface(s) associated with the given string.
|
||||
For example, providing @racket["127.0.0.1"] (the default) as @racket[listen-ip] creates a server that accepts only connections to @racket["127.0.0.1"] (the loopback interface) from the local machine.
|
||||
|
||||
|
||||
If @racket[ssl-key] and @racket[ssl-cert] are not false, then the server runs in HTTPS mode with @racket[ssl-cert]
|
||||
and @racket[ssl-key] as paths to the certificate and private key.
|
||||
|
||||
If @racket[connection-close?] is @racket[#t], then every connection is closed after one
|
||||
request. Otherwise, the client decides based on what HTTP version it uses.
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -124,6 +124,7 @@ and if @racket[serve/servlet] is run in another module.
|
|||
|
||||
@defproc[(serve/servlet [start (request? . -> . response/c)]
|
||||
[#:command-line? command-line? boolean? #f]
|
||||
[#:connection-close? connection-close? boolean? #f]
|
||||
[#:launch-browser? launch-browser? boolean? (not command-line?)]
|
||||
[#:quit? quit? boolean? (not command-line?)]
|
||||
[#:banner? banner? boolean? (not command-line?)]
|
||||
|
|
@ -204,6 +205,9 @@ and if @racket[serve/servlet] is run in another module.
|
|||
|
||||
If @racket[log-file] is given, then it used to log requests using @racket[log-format] as the format. Allowable formats
|
||||
are those allowed by @racket[log-format->format].
|
||||
|
||||
If @racket[connection-close?] is @racket[#t], then every connection is closed after one
|
||||
request. Otherwise, the client decides based on what HTTP version it uses.
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@
|
|||
dispatcher/c)]
|
||||
[serve/launch/wait (((semaphore? . -> . dispatcher/c))
|
||||
(#:launch-path (or/c false/c string?)
|
||||
#:connection-close? boolean?
|
||||
#:banner? boolean?
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:port tcp-listen-port?
|
||||
|
|
@ -86,6 +87,8 @@
|
|||
(define (serve/launch/wait
|
||||
dispatcher
|
||||
|
||||
#:connection-close?
|
||||
[connection-close? #f]
|
||||
#:launch-path
|
||||
[launch-path #f]
|
||||
#:banner?
|
||||
|
|
@ -104,6 +107,7 @@
|
|||
(define confirm-ch (make-async-channel 1))
|
||||
(define shutdown-server
|
||||
(serve #:confirmation-channel confirm-ch
|
||||
#:connection-close? connection-close?
|
||||
#:dispatch (dispatcher sema)
|
||||
#:listen-ip listen-ip
|
||||
#:port port-arg
|
||||
|
|
|
|||
|
|
@ -39,7 +39,8 @@
|
|||
|
||||
(provide/contract
|
||||
[serve/servlet (((request? . -> . response/c))
|
||||
(#:command-line? boolean?
|
||||
(#:connection-close? boolean?
|
||||
#:command-line? boolean?
|
||||
#:launch-browser? boolean?
|
||||
#:quit? boolean?
|
||||
#:banner? boolean?
|
||||
|
|
@ -75,6 +76,8 @@
|
|||
|
||||
(define (serve/servlet
|
||||
start
|
||||
#:connection-close?
|
||||
[connection-close? #f]
|
||||
#:command-line?
|
||||
[command-line? #f]
|
||||
#:launch-browser?
|
||||
|
|
@ -172,7 +175,8 @@
|
|||
#:indices (list "index.html" "index.htm"))
|
||||
(lift:make file-not-found-responder)))
|
||||
(serve/launch/wait
|
||||
dispatcher
|
||||
dispatcher
|
||||
#:connection-close? connection-close?
|
||||
#:launch-path (if launch-browser? servlet-path #f)
|
||||
#:banner? banner?
|
||||
#:listen-ip listen-ip
|
||||
|
|
|
|||
|
|
@ -17,28 +17,31 @@
|
|||
[serve
|
||||
(->* (#:dispatch dispatcher/c)
|
||||
(#:confirmation-channel (or/c false/c async-channel?)
|
||||
#:tcp@ (unit/c (import) (export tcp^))
|
||||
#:port tcp-listen-port?
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
#:connection-close? boolean?
|
||||
#:tcp@ (unit/c (import) (export tcp^))
|
||||
#:port tcp-listen-port?
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
(-> void))]
|
||||
[serve/ports
|
||||
(->* (#:dispatch dispatcher/c)
|
||||
(#:confirmation-channel (or/c false/c async-channel?)
|
||||
#:tcp@ (unit/c (import) (export tcp^))
|
||||
#:ports (listof tcp-listen-port?)
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
#:connection-close? boolean?
|
||||
#:tcp@ (unit/c (import) (export tcp^))
|
||||
#:ports (listof tcp-listen-port?)
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
(-> void))]
|
||||
[serve/ips+ports
|
||||
(->* (#:dispatch dispatcher/c)
|
||||
(#:confirmation-channel (or/c false/c async-channel?)
|
||||
#:tcp@ (unit/c (import) (export tcp^))
|
||||
#:ips+ports (listof (cons/c (or/c false/c string?) (listof tcp-listen-port?)))
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
#:connection-close? boolean?
|
||||
#:tcp@ (unit/c (import) (export tcp^))
|
||||
#:ips+ports (listof (cons/c (or/c false/c string?) (listof tcp-listen-port?)))
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
(-> void))]
|
||||
[do-not-return (-> void)]
|
||||
[serve/web-config@ (((unit/c (import) (export web-config^))) (#:tcp@ (unit/c (import) (export tcp^))) . ->* . (-> void?))])
|
||||
|
|
@ -49,12 +52,15 @@
|
|||
(define (serve
|
||||
#:dispatch dispatch
|
||||
#:confirmation-channel [confirmation-channel #f]
|
||||
#:connection-close? [connection-close? #f]
|
||||
#:tcp@ [tcp@ raw:tcp@]
|
||||
#:port [port 80]
|
||||
#:listen-ip [listen-ip #f]
|
||||
#:max-waiting [max-waiting 40]
|
||||
#:initial-connection-timeout [initial-connection-timeout 60])
|
||||
(define read-request http:read-request)
|
||||
(define read-request
|
||||
(http:make-read-request
|
||||
#:connection-close? connection-close?))
|
||||
(define-unit-binding a-tcp@
|
||||
tcp@ (import) (export tcp^))
|
||||
(define-compound-unit/infer dispatch-server@/tcp@
|
||||
|
|
@ -65,12 +71,13 @@
|
|||
dispatch-server@/tcp@
|
||||
(import dispatch-server-config^)
|
||||
(export dispatch-server^))
|
||||
|
||||
|
||||
(serve #:confirmation-channel confirmation-channel))
|
||||
|
||||
(define (serve/ports
|
||||
#:dispatch dispatch
|
||||
#:confirmation-channel [confirmation-channel #f]
|
||||
#:connection-close? [connection-close? #f]
|
||||
#:tcp@ [tcp@ raw:tcp@]
|
||||
#:ports [ports (list 80)]
|
||||
#:listen-ip [listen-ip #f]
|
||||
|
|
@ -80,6 +87,7 @@
|
|||
(map (lambda (port)
|
||||
(serve #:dispatch dispatch
|
||||
#:confirmation-channel confirmation-channel
|
||||
#:connection-close? connection-close?
|
||||
#:tcp@ tcp@
|
||||
#:port port
|
||||
#:listen-ip listen-ip
|
||||
|
|
@ -92,6 +100,7 @@
|
|||
(define (serve/ips+ports
|
||||
#:dispatch dispatch
|
||||
#:confirmation-channel [confirmation-channel #f]
|
||||
#:connection-close? [connection-close? #f]
|
||||
#:tcp@ [tcp@ raw:tcp@]
|
||||
#:ips+ports [ips+ports (list (cons #f (list 80)))]
|
||||
#:max-waiting [max-waiting 40]
|
||||
|
|
@ -101,6 +110,7 @@
|
|||
[(list-rest listen-ip ports)
|
||||
(serve #:dispatch dispatch
|
||||
#:confirmation-channel confirmation-channel
|
||||
#:connection-close? connection-close?
|
||||
#:tcp@ tcp@
|
||||
#:ports ports
|
||||
#:listen-ip listen-ip
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user