Fixing pr11125

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

collects/web-server/http/request.rkt

@@ -6,26 +6,27 @@
          web-server/private/connection-manager
          web-server/http/request-structs)
 
-(provide/contract
+(define read-request/c
- [read-headers (-> input-port? (listof header?))]
- [rename ext:read-request read-request
   (connection? 
    tcp-listen-port?
    (input-port? . -> . (values string? string?))
    . -> .
-          (values request? boolean?))])
+   (values request? boolean?)))
 
-(define (ext:read-request conn host-port port-addresses)
+(provide/contract
-  (with-handlers ([exn:fail? (lambda (exn)
+ [read-headers (-> input-port? (listof header?))]
-                          (kill-connection! conn)
+ [rename make-ext:read-request make-read-request
-                          (raise exn))])
+         (->* () (#:connection-close? boolean?) read-request/c)]
-    (read-request conn host-port port-addresses)))
+ [rename ext:read-request read-request
+         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)
+   (or connection-close?
        (close-connection? headers major minor
-                      client-ip host-ip)))
+                          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?

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]

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.
 }
               
 }

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.
 }
               
 }

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

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?
@@ -173,6 +176,7 @@
      (lift:make file-not-found-responder)))
   (serve/launch/wait
    dispatcher  
+   #:connection-close? connection-close?
    #:launch-path (if launch-browser? servlet-path #f) 
    #:banner? banner?   
    #:listen-ip listen-ip

collects/web-server/web-server.rkt

@@ -17,6 +17,7 @@
  [serve
   (->* (#:dispatch dispatcher/c)
        (#:confirmation-channel (or/c false/c async-channel?)
+                               #:connection-close? boolean?
                                #:tcp@ (unit/c (import) (export tcp^))
                                #:port tcp-listen-port?
                                #:listen-ip (or/c false/c string?)
@@ -26,6 +27,7 @@
  [serve/ports
   (->* (#:dispatch dispatcher/c)
        (#:confirmation-channel (or/c false/c async-channel?)
+                               #:connection-close? boolean?
                                #:tcp@ (unit/c (import) (export tcp^))
                                #:ports (listof tcp-listen-port?)
                                #:listen-ip (or/c false/c string?)
@@ -35,6 +37,7 @@
  [serve/ips+ports
   (->* (#:dispatch dispatcher/c)
        (#:confirmation-channel (or/c false/c async-channel?)
+                               #: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?
@@ -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@
@@ -71,6 +77,7 @@
 (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