Fixing conn mutexes and adding ssd

svn: r632

collects/web-server/response.ss

@@ -74,14 +74,22 @@
                                                                          . any)]
             )]
    [response? (any/c . -> . boolean?)]
-   [output-response (connection? any/c . -> . any)]
+   [rename ext:output-response output-response (connection? any/c . -> . any)]
-   [output-response/method (connection? response? symbol? . -> . any)]
+   [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)]
-   [output-file (connection? path? symbol? bytes? . -> . any)]
+   [rename ext:output-file output-file (connection? path? symbol? bytes? . -> . any)]
    [TEXT/HTML-MIME-TYPE bytes?]
    )
   
   
-  
+  (define (ext:output-response conn resp)
+    (call-with-semaphore (connection-mutex conn)
+                         (lambda () (output-response conn resp))))
+  (define (ext:output-response/method conn resp meth)
+    (call-with-semaphore (connection-mutex conn)
+                         (lambda () (output-response/method conn resp meth))))
+  (define (ext:output-file conn file-path method mime-type)
+    (call-with-semaphore (connection-mutex conn)
+                         (lambda () (output-file conn file-path method mime-type))))
   
   ;; Table 1. head responses:
   ; ------------------------------------------------------------------------------
@@ -176,14 +184,9 @@
   (define DAYS
     #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
     
-  
-  
   ;; **************************************************
   ;; output-response: connection response -> void
   (define (output-response conn resp)
-    (call-with-semaphore
-     (connection-mutex conn)
-     (lambda ()
        (cond
          [(response/full? resp)
           (output-response/basic
@@ -230,7 +233,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
@@ -245,9 +248,6 @@
   ;; **************************************************
   ;; 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)
@@ -256,21 +256,18 @@
       ; 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/servlet.ss

@@ -15,15 +15,13 @@
     (send/suspend ((string? . -> . any/c) . -> . request?))
     (send/forward ((string? . -> . any/c) . -> . request?))
     ;;; validate-xexpr/callback is not checked anywhere:
-    (send/suspend/callback (xexpr/callback? . -> . any))
+    (send/suspend/callback (xexpr/callback? . -> . any)))
-    )
 
   (provide
+   send/suspend/dispatch
    (all-from "servlet-helpers.ss")
-    (all-from "xexpr-callback.ss")
+   (all-from "xexpr-callback.ss"))
-    )
   
-
   ;; ************************************************************
   ;; EXPORTS
 
@@ -45,13 +43,12 @@
   (define (send/suspend response-generator)
     (let/cc k
       (let* ([inst (current-servlet-instance)]
-             [ctxt (servlet-instance-context inst)])
+             [ctxt (servlet-instance-context inst)]
-        (output-response
+             [k-url (store-continuation!
-         (execution-context-connection ctxt)
-         (response-generator
-          (store-continuation!
                      k (request-uri (execution-context-request ctxt))
-           inst)))
+                     inst)]
+             [response (response-generator k-url)])
+        (output-response (execution-context-connection ctxt) response)
         ((execution-context-suspend ctxt)))))
 
   ;; send/forward: (url -> response) -> request
@@ -63,10 +60,18 @@
   ;; send/suspend/callback : xexpr/callback? -> void
   ;; send/back a response with callbacks in it; send/suspend those callbacks.
   (define (send/suspend/callback p-exp)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       (replace-procedures p-exp embed/url))))
+    
+  ;; send/suspend/dispatch : ((proc -> url) -> response) -> request
+  ;; send/back a response generated from a procedure that may convert
+  ;; procedures to continuation urls
+  (define (send/suspend/dispatch response-generator)
     (let/cc k0
       (send/back
-        (replace-procedures
+       (response-generator
-          p-exp (lambda (proc)
+        (lambda (proc)
           (let/cc k1 (k0 (proc (send/suspend k1)))))))))