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)
 
+(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? 
+         read-request/c])
-          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: 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
+   (or connection-close?
-                      client-ip host-ip)))
+       (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)
+               (filter (lambda (x) x)
-                     (map (match-lambda
+                       (map (match-lambda
-                            [(list-rest k v)
+                              [(list-rest k v)
-                             (if (and (symbol? k) (string? v))
+                               (if (and (symbol? k) (string? v))
-                                 (make-binding:form (string->bytes/utf-8 (symbol->string k))
+                                   (make-binding:form (string->bytes/utf-8 (symbol->string k))
-                                                    (string->bytes/utf-8 v))
+                                                      (string->bytes/utf-8 v))
-                                 #f)])
+                                   #f)])
-                          (url-query uri))))
+                            (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))
+                         [(struct mime-part (headers contents))
-                         (define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
+                          (define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
-                         (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
+                          (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
-                                      (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
+                                       (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
-                           [(list #f #f)
+                            [(list #f #f)
-                            (network-error 'reading-bindings "Couldn't extract form field name for file upload")]
+                             (network-error 'reading-bindings "Couldn't extract form field name for file upload")]
-                           [(list #f (list _ _ f0 f1))
+                            [(list #f (list _ _ f0 f1))
-                            (make-binding:form (or f0 f1) (apply bytes-append contents))]
+                             (make-binding:form (or f0 f1) (apply bytes-append contents))]
-                           [(list (list _ _ f00 f01) (list _ _ f10 f11))
+                            [(list (list _ _ f00 f01) (list _ _ f10 f11))
-                            (make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
+                             (make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
-                      (read-mime-multipart content-boundary in)))
+                       (read-mime-multipart content-boundary in)))
                 (values
                  (delay bs)
                  #f)])]

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

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^))
+                               #:connection-close? boolean?
-        #:port tcp-listen-port?
+                               #:tcp@ (unit/c (import) (export tcp^))
-        #:listen-ip (or/c false/c string?)
+                               #:port tcp-listen-port?
-        #:max-waiting number?
+                               #:listen-ip (or/c false/c string?)
-        #:initial-connection-timeout number?)
+                               #: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^))
+                               #:connection-close? boolean?
-        #:ports (listof tcp-listen-port?)
+                               #:tcp@ (unit/c (import) (export tcp^))
-        #:listen-ip (or/c false/c string?)
+                               #:ports (listof tcp-listen-port?)
-        #:max-waiting number?
+                               #:listen-ip (or/c false/c string?)
-        #:initial-connection-timeout number?)
+                               #: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^))
+                               #:connection-close? boolean?
-        #:ips+ports (listof (cons/c (or/c false/c string?) (listof tcp-listen-port?)))
+                               #:tcp@ (unit/c (import) (export tcp^))
-        #:max-waiting number?
+                               #:ips+ports (listof (cons/c (or/c false/c string?) (listof tcp-listen-port?)))
-        #:initial-connection-timeout number?)
+                               #: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