PR 7450

svn: r630

collects/web-server/connection-manager.ss

@@ -6,14 +6,14 @@
   (require "timer.ss"
            (lib "contract.ss"))
   
-  (define-struct connection (timer i-port o-port custodian close?)
+  (define-struct connection (timer i-port o-port custodian close? mutex)
     (make-inspector))
   
   (provide/contract
    [struct connection
            ([timer timer?]
             [i-port input-port?] [o-port output-port?] [custodian custodian?]
-            [close? boolean?])]
+            [close? boolean?] [mutex semaphore?])]
    [start-connection-manager (custodian? . -> . void)]
    [new-connection (number? input-port? output-port? custodian? boolean? . -> . connection?)]
    [kill-connection! (connection? . -> . void)]
@@ -26,23 +26,33 @@
   ;; new-connection: number i-port o-port custodian -> connection
   ;; ask the connection manager for a new connection
   (define (new-connection time-to-live i-port o-port cust close?)
+    (let ([mutex (make-semaphore 1)])
       (make-connection
        (start-timer time-to-live
+                    (lambda () 
+                      (call-with-semaphore
+                       mutex
                        (lambda ()
                          (close-output-port o-port)
                          (close-input-port i-port)
-                    (custodian-shutdown-all cust)))
-     i-port o-port cust close?))
+                         (custodian-shutdown-all cust)))))
+       i-port o-port cust close? mutex)))
   
   ;; kill-connection!: connection -> void
   ;; kill this connection
   (define (kill-connection! conn-demned)
+    (call-with-semaphore
+     (connection-mutex conn-demned)
+     (lambda ()
        (close-output-port (connection-o-port conn-demned))
        (close-input-port (connection-i-port conn-demned))
-    (custodian-shutdown-all (connection-custodian conn-demned)))
+       (custodian-shutdown-all (connection-custodian conn-demned)))))
   
   ;; adjust-connection-timeout!: connection number -> void
   ;; change the expiration time for this connection
   (define (adjust-connection-timeout! conn time)
-    (reset-timer (connection-timer conn) time))
+    (call-with-semaphore
+     (connection-mutex conn)
+     (lambda ()
+       (reset-timer (connection-timer conn) time))))
   )

collects/web-server/request-parsing.ss

@@ -32,7 +32,7 @@
                     [bindings (union (listof binding?) string?)]
                     [host-ip string?]
                     [client-ip string?])]
-   [read-request ((input-port?) . ->* . (request? boolean?))]
+   [read-request ((connection?) . ->* . (request? boolean?))]
    [read-bindings (connection? symbol? url? (listof header?)
                                . -> . (union (listof binding?) string?))])
 
@@ -40,7 +40,11 @@
   ;; read-request: input-port -> 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 ip)
+  (define (read-request conn)
+    (call-with-semaphore
+     (connection-mutex conn)
+     (lambda ()
+       (let ([ip (connection-i-port conn)])
          (let-values ([(method uri major-version minor-version)
                        (read-request-line ip)])
            (let ([headers (read-headers ip)])
@@ -51,7 +55,7 @@
                (values
                 (make-request method uri headers '() host-ip client-ip)
                 (close-connection?
-            headers major-version minor-version client-ip host-ip))))))
+                 headers major-version minor-version client-ip host-ip)))))))))
 
   ;; **************************************************
   ;; close-connection?
@@ -164,6 +168,9 @@
     (case meth
       [(get) (url-query uri)]
       [(post)
+       (call-with-semaphore
+        (connection-mutex conn)
+        (lambda ()
           (let ([content-type (assq 'content-type headers)])
             (cond
               [(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type)))
@@ -186,7 +193,7 @@
                               (let ([s (read-string INPUT-BUFFER-SIZE in)])
                                 (if (eof-object? s)
                                     null
-                              (cons s (read-to-eof))))))))]))]
+                                    (cons s (read-to-eof))))))))]))))]
       [else (error "unsupported method" meth)]))
 
   (define FILE-FORM-REGEXP (regexp "multipart/form-data; *boundary=(.*)"))

collects/web-server/response.ss

@@ -181,6 +181,9 @@
   ;; **************************************************
   ;; output-response: connection response -> void
   (define (output-response conn resp)
+    (call-with-semaphore
+     (connection-mutex conn)
+     (lambda ()
        (cond
          [(response/full? resp)
           (output-response/basic
@@ -227,7 +230,7 @@
                (add1 (string-length str))
                (lambda (o-port)
                  (display str o-port)
-              (newline o-port)))))]))
+                 (newline o-port)))))]))))
   
   ;; response/full->size: response/full -> number
   ;; compute the size for a response/full
@@ -242,6 +245,9 @@
   ;; **************************************************
   ;; output-file: connection path symbol bytes -> void
   (define (output-file conn file-path method mime-type)
+    (call-with-semaphore
+     (connection-mutex conn)
+     (lambda ()
        (output-headers conn 200 "Okay"
                        `(("Content-length: " ,(file-size file-path)))
                        (file-or-directory-modify-seconds file-path)
@@ -250,18 +256,21 @@
          ; Give it one second per byte.
          (adjust-connection-timeout! conn (file-size file-path))
          (call-with-input-file file-path
-        (lambda (i-port) (copy-port i-port (connection-o-port conn))))))
+           (lambda (i-port) (copy-port i-port (connection-o-port conn))))))))
   
   ;; **************************************************
   ;; output-response/method: connection response/full symbol -> void
   ;; If it is a head request output headers only, otherwise output as usual
   (define (output-response/method conn resp meth)
+    (call-with-semaphore
+     (connection-mutex conn)
+     (lambda ()
        (cond
          [(eqv? meth 'head)
           (output-headers/response conn resp `(("Content-length: "
                                                 ,(response/full->size resp))))]
          [else
-       (output-response conn resp)]))
+          (output-response conn resp)]))))
   
   ;; **************************************************
   ;; output-headers/response: connection response (listof (listof string)) -> void

collects/web-server/web-server-unit.ss

@@ -113,7 +113,7 @@
       ;; respond to all requests on this connection
       (define (serve-connection conn)
         (let connection-loop ()
-          (let-values ([(req close?) (read-request (connection-i-port conn))])
+          (let-values ([(req close?) (read-request conn)])
             (let* ([host (get-host (request-uri req) (request-headers req))]
                    [host-conf (config:virtual-hosts host)])
               ((host-log-message host-conf) (request-host-ip req)
@@ -125,8 +125,6 @@
                 [close? (kill-connection! conn)]
                 [else (connection-loop)])))))
       
-      
-      
       ;; dispatch: connection request host -> void
       ;; NOTE: (GregP) I'm going to use the dispatch logic out of v208 for now.
       ;;       I will move the other  dispatch logic out of the prototype
@@ -161,8 +159,7 @@
                 (output-response/method
                  conn
                  ((responders-passwords-refreshed (host-responders host-info)))
-                 method)
-                ]
+                 method)]
                [else
                 (output-response/method
                  conn