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?)
-    (make-connection
+    (let ([mutex (make-semaphore 1)])
-     (start-timer time-to-live
+      (make-connection
-                  (lambda () 
+       (start-timer time-to-live
-                    (close-output-port o-port)
+                    (lambda () 
-                    (close-input-port i-port)
+                      (call-with-semaphore
-                    (custodian-shutdown-all cust)))
+                       mutex
-     i-port o-port cust close?))
+                       (lambda ()
+                         (close-output-port o-port)
+                         (close-input-port i-port)
+                         (custodian-shutdown-all cust)))))
+       i-port o-port cust close? mutex)))
   
   ;; kill-connection!: connection -> void
   ;; kill this connection
   (define (kill-connection! conn-demned)
-    (close-output-port (connection-o-port conn-demned))
+    (call-with-semaphore
-    (close-input-port (connection-i-port conn-demned))
+     (connection-mutex conn-demned)
-    (custodian-shutdown-all (connection-custodian 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)))))
   
   ;; 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,18 +40,22 @@
   ;; 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)
-    (let-values ([(method uri major-version minor-version)
+    (call-with-semaphore
-                  (read-request-line ip)])
+     (connection-mutex conn)
-      (let ([headers (read-headers ip)])
+     (lambda ()
-        (let-values ([(host-ip client-ip)
+       (let ([ip (connection-i-port conn)])
-                      (if (tcp-port? ip)
+         (let-values ([(method uri major-version minor-version)
-                          (tcp-addresses ip)
+                       (read-request-line ip)])
-                          (values "127.0.0.1" "127.0.0.1"))])
+           (let ([headers (read-headers ip)])
-          (values
+             (let-values ([(host-ip client-ip)
-           (make-request method uri headers '() host-ip client-ip)
+                           (if (tcp-port? ip)
-           (close-connection?
+                               (tcp-addresses ip)
-            headers major-version minor-version client-ip host-ip))))))
+                               (values "127.0.0.1" "127.0.0.1"))])
+               (values
+                (make-request method uri headers '() host-ip client-ip)
+                (close-connection?
+                 headers major-version minor-version client-ip host-ip)))))))))
 
   ;; **************************************************
   ;; close-connection?
@@ -164,29 +168,32 @@
     (case meth
       [(get) (url-query uri)]
       [(post)
-       (let ([content-type (assq 'content-type headers)])
+       (call-with-semaphore
-         (cond
+        (connection-mutex conn)
-           [(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type)))
+        (lambda ()
-             => (lambda (content-boundary)
+          (let ([content-type (assq 'content-type headers)])
-                  (map (lambda (part)
+            (cond
-                         ;; more here - better checks, avoid string-append
+              [(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type)))
-                         (cons (get-field-name (cdr (assq 'content-disposition (car part))))
+               => (lambda (content-boundary)
-                               (apply bytes-append (cdr part))))
+                    (map (lambda (part)
-                       (read-mime-multipart (cadr content-boundary) (connection-i-port conn))))]
+                           ;; more here - better checks, avoid string-append
-             [else
+                           (cons (get-field-name (cdr (assq 'content-disposition (car part))))
-             (let ([len-str (assq 'content-length headers)]
+                                 (apply bytes-append (cdr part))))
-                   [in (connection-i-port conn)])
+                         (read-mime-multipart (cadr content-boundary) (connection-i-port conn))))]
-               (if len-str
+              [else
-                 (cond
+               (let ([len-str (assq 'content-length headers)]
-                   [(string->number (bytes->string/utf-8 (cdr len-str)))
+                     [in (connection-i-port conn)])
-                    => (lambda (len) (read-string len in))]
+                 (if len-str
-                    [else (error "Post request contained a non-numeric content-length")])
+                     (cond
-                 (apply string-append
+                       [(string->number (bytes->string/utf-8 (cdr len-str)))
-                        (let read-to-eof ()
+                        => (lambda (len) (read-string len in))]
-                          (let ([s (read-string INPUT-BUFFER-SIZE in)])
+                       [else (error "Post request contained a non-numeric content-length")])
-                            (if (eof-object? s)
+                     (apply string-append
-                              null
+                            (let read-to-eof ()
-                              (cons s (read-to-eof))))))))]))]
+                              (let ([s (read-string INPUT-BUFFER-SIZE in)])
+                                (if (eof-object? s)
+                                    null
+                                    (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,53 +181,56 @@
   ;; **************************************************
   ;; output-response: connection response -> void
   (define (output-response conn resp)
-    (cond
+    (call-with-semaphore
-      [(response/full? resp)
+     (connection-mutex conn)
-       (output-response/basic
+     (lambda ()
-        conn resp (response/full->size resp)
+       (cond
-        (lambda (o-port)
+         [(response/full? resp)
-          (for-each
+          (output-response/basic
-           (lambda (str) (display str o-port))
+           conn resp (response/full->size resp)
-           (response/full-body resp))))]
+           (lambda (o-port)
-      [(response/incremental? resp)
+             (for-each
-       (output-response/incremental conn resp)]
+              (lambda (str) (display str o-port))
-      [(and (pair? resp) (string? (car resp)))
+              (response/full-body resp))))]
-       (output-response/basic
+         [(response/incremental? resp)
-        conn
+          (output-response/incremental conn resp)]
-        (make-response/basic 200 "Okay" (current-seconds) (car resp) '())
+         [(and (pair? resp) (string? (car resp)))
-        (apply + (map
+          (output-response/basic
-                  (lambda (c)
+           conn
-                    (if (string? c)
+           (make-response/basic 200 "Okay" (current-seconds) (car resp) '())
-                        (string-length c)
+           (apply + (map
-                        (bytes-length c)))
+                     (lambda (c)
-                  (cdr resp)))
+                       (if (string? c)
-        (lambda (o-port)
+                           (string-length c)
-          (for-each
+                           (bytes-length c)))
-           (lambda (str) (display str o-port))
+                     (cdr resp)))
-           (cdr resp))))]
+           (lambda (o-port)
-      [else
+             (for-each
-       ;; TODO: make a real exception for this.
+              (lambda (str) (display str o-port))
-       (with-handlers
+              (cdr resp))))]
-           ([exn:invalid-xexpr?
+         [else
-             (lambda (exn)
+          ;; TODO: make a real exception for this.
-               (output-response/method
+          (with-handlers
-                conn
+              ([exn:invalid-xexpr?
-                (xexpr-exn->response exn resp)
+                (lambda (exn)
-                'ignored))]
+                  (output-response/method
-            [exn? (lambda (exn)
+                   conn
-                    (raise exn))])
+                   (xexpr-exn->response exn resp)
-         (let ([str (and (validate-xexpr resp) (xexpr->string resp))])
+                   'ignored))]
-           (output-response/basic
+               [exn? (lambda (exn)
-            conn
+                       (raise exn))])
-            (make-response/basic 200
+            (let ([str (and (validate-xexpr resp) (xexpr->string resp))])
-                                 "Okay"
+              (output-response/basic
-                                 (current-seconds)
+               conn
-                                 TEXT/HTML-MIME-TYPE
+               (make-response/basic 200
-                                 '())
+                                    "Okay"
-            (add1 (string-length str))
+                                    (current-seconds)
-            (lambda (o-port)
+                                    TEXT/HTML-MIME-TYPE
-              (display str o-port)
+                                    '())
-              (newline o-port)))))]))
+               (add1 (string-length str))
+               (lambda (o-port)
+                 (display str o-port)
+                 (newline o-port)))))]))))
   
   ;; response/full->size: response/full -> number
   ;; compute the size for a response/full
@@ -242,26 +245,32 @@
   ;; **************************************************
   ;; output-file: connection path symbol bytes -> void
   (define (output-file conn file-path method mime-type)
-    (output-headers conn 200 "Okay"
+    (call-with-semaphore
-                    `(("Content-length: " ,(file-size file-path)))
+     (connection-mutex conn)
-                    (file-or-directory-modify-seconds file-path)
+     (lambda ()
-                    mime-type)
+       (output-headers conn 200 "Okay"
-    (when (eq? method 'get)
+                       `(("Content-length: " ,(file-size file-path)))
-      ; Give it one second per byte.
+                       (file-or-directory-modify-seconds file-path)
-      (adjust-connection-timeout! conn (file-size file-path))
+                       mime-type)
-      (call-with-input-file file-path
+       (when (eq? method 'get)
-        (lambda (i-port) (copy-port i-port (connection-o-port conn))))))
+         ; 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))))))))
   
   ;; **************************************************
   ;; 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)
-    (cond
+    (call-with-semaphore
-      [(eqv? meth 'head)
+     (connection-mutex conn)
-       (output-headers/response conn resp `(("Content-length: "
+     (lambda ()
-                                             ,(response/full->size resp))))]
+       (cond
-      [else
+         [(eqv? meth 'head)
-       (output-response conn resp)]))
+          (output-headers/response conn resp `(("Content-length: "
+                                                ,(response/full->size resp))))]
+         [else
+          (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