From a257bb310bd42fe0b4fdf4681dbb60977e698928 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 22 Aug 2005 15:35:32 +0000 Subject: [PATCH] Fixing conn mutexes and adding ssd svn: r632 --- collects/web-server/response.ss | 61 ++++++++++++++++----------------- collects/web-server/servlet.ss | 41 ++++++++++++---------- 2 files changed, 52 insertions(+), 50 deletions(-) diff --git a/collects/web-server/response.ss b/collects/web-server/response.ss index b0f845609a..88e18aaaab 100644 --- a/collects/web-server/response.ss +++ b/collects/web-server/response.ss @@ -74,14 +74,22 @@ . any)] )] [response? (any/c . -> . boolean?)] - [output-response (connection? any/c . -> . any)] - [output-response/method (connection? response? symbol? . -> . any)] - [output-file (connection? path? symbol? bytes? . -> . any)] + [rename ext:output-response output-response (connection? any/c . -> . any)] + [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . 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: ; ------------------------------------------------------------------------------ @@ -175,15 +183,10 @@ (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,32 +248,26 @@ ;; ************************************************** ;; 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) - mime-type) - (when (eq? method 'get) - ; 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-headers conn 200 "Okay" + `(("Content-length: " ,(file-size file-path))) + (file-or-directory-modify-seconds file-path) + mime-type) + (when (eq? method 'get) + ; 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) - (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)])))) + (cond + [(eqv? meth 'head) + (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 diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 57401ad292..75f9f13e14 100644 --- a/collects/web-server/servlet.ss +++ b/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 - (all-from "servlet-helpers.ss") - (all-from "xexpr-callback.ss") - ) - - + send/suspend/dispatch + (all-from "servlet-helpers.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)]) - (output-response - (execution-context-connection ctxt) - (response-generator - (store-continuation! - k (request-uri (execution-context-request ctxt)) - inst))) + [ctxt (servlet-instance-context inst)] + [k-url (store-continuation! + k (request-uri (execution-context-request ctxt)) + inst)] + [response (response-generator k-url)]) + (output-response (execution-context-connection ctxt) response) ((execution-context-suspend ctxt))))) ;; send/forward: (url -> response) -> request @@ -59,15 +56,23 @@ (define (send/forward response-generator) (clear-continuations! (current-servlet-instance)) (send/suspend response-generator)) - + ;; 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 - p-exp (lambda (proc) - (let/cc k1 (k0 (proc (send/suspend k1))))))))) + (response-generator + (lambda (proc) + (let/cc k1 (k0 (proc (send/suspend k1))))))))) ;; ************************************************************