diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 85445ca33c..db90d7c134 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -8,8 +8,11 @@ "../private/web-server-structs.ss" "../private/connection-manager.ss" "../private/response.ss" + "../request-structs.ss" + "../servlet-structs.ss" "../response-structs.ss" - "../servlet.ss" + "../servlet/web-cells.ss" + "../servlet/web.ss" "../private/configuration.ss" "../private/util.ss" "../managers/manager.ss" diff --git a/collects/web-server/prototype-web-server/lang-api.ss b/collects/web-server/prototype-web-server/lang-api.ss index f0504269cd..5eaa7c5d7b 100644 --- a/collects/web-server/prototype-web-server/lang-api.ss +++ b/collects/web-server/prototype-web-server/lang-api.ss @@ -2,6 +2,7 @@ (require (lib "url.ss" "net") "../request-structs.ss" "../response-structs.ss" + "../servlet/helpers.ss" "private/abort-resume.ss" "private/web.ss" "lang-api/web-cells.ss" @@ -11,7 +12,8 @@ (provide (all-from-except mzscheme #%module-begin) (all-from (lib "url.ss" "net")) (all-from "../request-structs.ss") - (all-from "../response-structs.ss") + (all-from "../response-structs.ss") + (all-from "../servlet/helpers.ss") (all-from "private/abort-resume.ss") (all-from "private/web.ss") (all-from "lang-api/web-cells.ss") diff --git a/collects/web-server/prototype-web-server/lang-api/web-extras.ss b/collects/web-server/prototype-web-server/lang-api/web-extras.ss index 15953825cf..ce199b1d58 100644 --- a/collects/web-server/prototype-web-server/lang-api/web-extras.ss +++ b/collects/web-server/prototype-web-server/lang-api/web-extras.ss @@ -1,23 +1,9 @@ (module web-extras mzscheme (require (lib "url.ss" "net") "../private/web.ss" - (only "../../servlet/helpers.ss" - extract-user-pass - redirect-to - permanently - temporarily - see-other - request-bindings - request-headers)) + "../../servlet/helpers.ss") (provide send/suspend/dispatch - redirect/get - extract-user-pass - redirect-to - permanently - temporarily - see-other - request-bindings - request-headers) + redirect/get) (define-syntax send/suspend/dispatch (syntax-rules () diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 5c65ad19eb..9c8cd58894 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,151 +1,20 @@ (module servlet mzscheme - (require (lib "contract.ss") - (lib "etc.ss") - (lib "xml.ss" "xml")) - (require "managers/manager.ss" - "private/servlet.ss" - "private/url.ss" - "servlet/helpers.ss" + (require "servlet/helpers.ss" "servlet/web-cells.ss" "servlet/bindings.ss" "servlet/basic-auth.ss" "servlet/servlet-url.ss" + "servlet/web.ss" "response-structs.ss" "request-structs.ss" "servlet-structs.ss") - (provide (all-from "servlet/web-cells.ss") + (provide (all-from "servlet/web.ss") + (all-from "servlet/web-cells.ss") (all-from "servlet/helpers.ss") (all-from "servlet/servlet-url.ss") (all-from "servlet-structs.ss") (all-from "servlet/bindings.ss") (all-from "servlet/basic-auth.ss") (all-from "response-structs.ss") - (all-from "request-structs.ss")) - - ;; ************************************************************ - ;; HELPERS - - ;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr? - ;; Change procedures to the send/suspend of a k-url - (define (xexpr/callback->xexpr p->a p-exp) - (cond - [(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e)) - p-exp)] - [(procedure? p-exp) (p->a p-exp)] - [else p-exp])) - - ;; Weak contracts: the input is checked in output-response, and a message is - ;; sent directly to the client (Web browser) instead of the terminal/log. - (provide/contract - [xexpr/callback->xexpr (embed/url? xexpr/callback? . -> . xexpr?)] - ; XXX contract - [current-url-transform parameter?] - ; XXX contract - [current-servlet-continuation-expiration-handler parameter?] - [redirect/get (-> request?)] - [redirect/get/forget (-> request?)] - [adjust-timeout! (number? . -> . void?)] - [clear-continuation-table! (-> void?)] - [send/back (any/c . -> . void?)] - [send/finish (any/c . -> . void?)] - [send/suspend ((response-generator?) (expiration-handler?) . opt-> . request?)] - [send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)] - [send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)] - [send/suspend/callback (xexpr/callback? . -> . any/c)]) - - ;; ************************************************************ - ;; EXPORTS - - ;; current-url-transform : string? -> string? - (define (default-url-transformer x) x) - (define current-url-transform - (make-parameter default-url-transformer)) - - ;; current-servlet-continuation-expiration-handler : request -> response - (define current-servlet-continuation-expiration-handler - (make-parameter #f)) - - ;; adjust-timeout! : sec -> void - ;; adjust the timeout on the servlet - (define (adjust-timeout! secs) - ((manager-adjust-timeout! (current-servlet-manager)) (get-current-servlet-instance-id) secs)) - - ;; ext:clear-continuations! -> void - (define (clear-continuation-table!) - ((manager-clear-continuations! (current-servlet-manager)) (get-current-servlet-instance-id))) - - ;; send/back: response -> void - ;; send a response and don't clear the continuation table - (define (send/back resp) - (define ctxt (thread-cell-ref current-execution-context)) - ((execution-context-suspend ctxt) resp)) - - ;; send/finish: response -> void - ;; send a response and clear the continuation table - (define (send/finish resp) - (clear-continuation-table!) - ; If we readjust the timeout to something small, the session will expire shortly - ; we cannot wait for send/back to return, because it doesn't - ; Also, we cannot get the initial-connection-timeout variable from here - ; In the future, we should use the servlet's specific default-timeout - (adjust-timeout! 10) - (send/back resp)) - - ;; send/suspend: (url -> response) [(request -> response)] -> request - ;; send a response and apply the continuation to the next request - (define send/suspend - (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) - (with-frame-after - (let/cc k - (define instance-id (get-current-servlet-instance-id)) - (define ctxt (thread-cell-ref current-execution-context)) - (define k-embedding ((manager-continuation-store! (current-servlet-manager)) - instance-id - (make-custodian-box (current-custodian) k) - expiration-handler)) - (define k-url ((current-url-transform) - (embed-ids - (list* instance-id k-embedding) - (request-uri (execution-context-request ctxt))))) - (send/back (response-generator k-url)))))) - - ;; send/forward: (url -> response) [(request -> response)] -> request - ;; clear the continuation table, then behave like send/suspend - (define send/forward - (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) - (clear-continuation-table!) - (send/suspend response-generator expiration-handler))) - - ;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request - ;; send/back a response generated from a procedure that may convert - ;; procedures to continuation urls - (define (send/suspend/dispatch response-generator) - ; This restores the tail position. - ; Note: Herman's syntactic strategy would fail without the new-request capture. - ; (Moving this to the tail-position is not possible anyway, by the way.) - (let ([thunk - (let/cc k0 - (send/back - (response-generator - (opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) - (let/ec k1 - (let ([new-request (send/suspend k1 expiration-handler)]) - (k0 (lambda () (proc new-request)))))))))]) - (thunk))) - - ;; 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) - (xexpr/callback->xexpr embed/url p-exp)))) - - ;; ************************************************************ - ;; HIGHER-LEVEL EXPORTS - - (define ((make-redirect/get send/suspend)) - (send/suspend (lambda (k-url) (redirect-to k-url temporarily)))) - - ; redirect/get : -> request - (define redirect/get (make-redirect/get send/suspend)) - (define redirect/get/forget (make-redirect/get send/forward))) \ No newline at end of file + (all-from "request-structs.ss") + (all-from "servlet-structs.ss"))) \ No newline at end of file diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss new file mode 100644 index 0000000000..8ea4f0998f --- /dev/null +++ b/collects/web-server/servlet/web.ss @@ -0,0 +1,139 @@ +(module web mzscheme + (require (lib "contract.ss") + (lib "etc.ss") + (lib "xml.ss" "xml")) + (require "../managers/manager.ss" + "../private/servlet.ss" + "../private/url.ss" + "../servlet/helpers.ss" + "../servlet/web-cells.ss" + "../request-structs.ss" + "../servlet-structs.ss") + + ;; ************************************************************ + ;; HELPERS + + ;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr? + ;; Change procedures to the send/suspend of a k-url + (define (xexpr/callback->xexpr p->a p-exp) + (cond + [(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e)) + p-exp)] + [(procedure? p-exp) (p->a p-exp)] + [else p-exp])) + + ;; Weak contracts: the input is checked in output-response, and a message is + ;; sent directly to the client (Web browser) instead of the terminal/log. + (provide/contract + [xexpr/callback->xexpr (embed/url? xexpr/callback? . -> . xexpr?)] + ; XXX contract + [current-url-transform parameter?] + ; XXX contract + [current-servlet-continuation-expiration-handler parameter?] + [redirect/get (-> request?)] + [redirect/get/forget (-> request?)] + [adjust-timeout! (number? . -> . void?)] + [clear-continuation-table! (-> void?)] + [send/back (any/c . -> . void?)] + [send/finish (any/c . -> . void?)] + [send/suspend ((response-generator?) (expiration-handler?) . opt-> . request?)] + [send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)] + [send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)] + [send/suspend/callback (xexpr/callback? . -> . any/c)]) + + ;; ************************************************************ + ;; EXPORTS + + ;; current-url-transform : string? -> string? + (define (default-url-transformer x) x) + (define current-url-transform + (make-parameter default-url-transformer)) + + ;; current-servlet-continuation-expiration-handler : request -> response + (define current-servlet-continuation-expiration-handler + (make-parameter #f)) + + ;; adjust-timeout! : sec -> void + ;; adjust the timeout on the servlet + (define (adjust-timeout! secs) + ((manager-adjust-timeout! (current-servlet-manager)) (get-current-servlet-instance-id) secs)) + + ;; ext:clear-continuations! -> void + (define (clear-continuation-table!) + ((manager-clear-continuations! (current-servlet-manager)) (get-current-servlet-instance-id))) + + ;; send/back: response -> void + ;; send a response and don't clear the continuation table + (define (send/back resp) + (define ctxt (thread-cell-ref current-execution-context)) + ((execution-context-suspend ctxt) resp)) + + ;; send/finish: response -> void + ;; send a response and clear the continuation table + (define (send/finish resp) + (clear-continuation-table!) + ; If we readjust the timeout to something small, the session will expire shortly + ; we cannot wait for send/back to return, because it doesn't + ; Also, we cannot get the initial-connection-timeout variable from here + ; In the future, we should use the servlet's specific default-timeout + (adjust-timeout! 10) + (send/back resp)) + + ;; send/suspend: (url -> response) [(request -> response)] -> request + ;; send a response and apply the continuation to the next request + (define send/suspend + (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) + (with-frame-after + (let/cc k + (define instance-id (get-current-servlet-instance-id)) + (define ctxt (thread-cell-ref current-execution-context)) + (define k-embedding ((manager-continuation-store! (current-servlet-manager)) + instance-id + (make-custodian-box (current-custodian) k) + expiration-handler)) + (define k-url ((current-url-transform) + (embed-ids + (list* instance-id k-embedding) + (request-uri (execution-context-request ctxt))))) + (send/back (response-generator k-url)))))) + + ;; send/forward: (url -> response) [(request -> response)] -> request + ;; clear the continuation table, then behave like send/suspend + (define send/forward + (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) + (clear-continuation-table!) + (send/suspend response-generator expiration-handler))) + + ;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request + ;; send/back a response generated from a procedure that may convert + ;; procedures to continuation urls + (define (send/suspend/dispatch response-generator) + ; This restores the tail position. + ; Note: Herman's syntactic strategy would fail without the new-request capture. + ; (Moving this to the tail-position is not possible anyway, by the way.) + (let ([thunk + (let/cc k0 + (send/back + (response-generator + (opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) + (let/ec k1 + (let ([new-request (send/suspend k1 expiration-handler)]) + (k0 (lambda () (proc new-request)))))))))]) + (thunk))) + + ;; 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) + (xexpr/callback->xexpr embed/url p-exp)))) + + ;; ************************************************************ + ;; HIGHER-LEVEL EXPORTS + + (define ((make-redirect/get send/suspend)) + (send/suspend (lambda (k-url) (redirect-to k-url temporarily)))) + + ; redirect/get : -> request + (define redirect/get (make-redirect/get send/suspend)) + (define redirect/get/forget (make-redirect/get send/forward))) \ No newline at end of file