diff --git a/collects/tests/web-server/pr/11125.rkt b/collects/tests/web-server/pr/11125.rkt new file mode 100644 index 0000000000..7d470fc19e --- /dev/null +++ b/collects/tests/web-server/pr/11125.rkt @@ -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)) diff --git a/collects/web-server/http/request.rkt b/collects/web-server/http/request.rkt index eabd372116..03fbf8cd98 100644 --- a/collects/web-server/http/request.rkt +++ b/collects/web-server/http/request.rkt @@ -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)])] diff --git a/collects/web-server/scribblings/launch.scrbl b/collects/web-server/scribblings/launch.scrbl index fe9e406aa5..a16533c788 100644 --- a/collects/web-server/scribblings/launch.scrbl +++ b/collects/web-server/scribblings/launch.scrbl @@ -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] diff --git a/collects/web-server/scribblings/servlet-env-int.scrbl b/collects/web-server/scribblings/servlet-env-int.scrbl index 518ca99832..6e38992f55 100644 --- a/collects/web-server/scribblings/servlet-env-int.scrbl +++ b/collects/web-server/scribblings/servlet-env-int.scrbl @@ -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. } } diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 73289454c8..4bbd6307fc 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -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. } } diff --git a/collects/web-server/servlet-dispatch.rkt b/collects/web-server/servlet-dispatch.rkt index 187f9d57a7..6e833c5a2b 100644 --- a/collects/web-server/servlet-dispatch.rkt +++ b/collects/web-server/servlet-dispatch.rkt @@ -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 diff --git a/collects/web-server/servlet-env.rkt b/collects/web-server/servlet-env.rkt index b0d4535f7c..624c023088 100644 --- a/collects/web-server/servlet-env.rkt +++ b/collects/web-server/servlet-env.rkt @@ -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 diff --git a/collects/web-server/web-server.rkt b/collects/web-server/web-server.rkt index 82f600adf9..7990230772 100644 --- a/collects/web-server/web-server.rkt +++ b/collects/web-server/web-server.rkt @@ -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