From e1dab52b0738b47003dbe26bfed6f427e80a63b7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 3 Mar 2009 20:02:31 +0000 Subject: [PATCH] compat svn: r13922 --- collects/tests/web-server/lang-test.ss | 28 +++++++-------- .../tests/web-server/lang/web-param-test.ss | 2 +- .../htdocs/lang-servlets/add06.ss | 2 +- .../htdocs/lang-servlets/mm00.ss | 2 +- .../htdocs/lang-servlets/mm01.ss | 2 +- .../htdocs/lang-servlets/wc-comp.ss | 2 +- .../htdocs/lang-servlets/wc-fake.ss | 2 +- .../htdocs/lang-servlets/wc.ss | 2 +- collects/web-server/lang/abort-resume.ss | 4 +-- collects/web-server/lang/web.ss | 32 +++++++++++++---- collects/web-server/scribblings/lang.scrbl | 16 +++++++-- collects/web-server/scribblings/web.scrbl | 23 ++++++++---- collects/web-server/scribblings/writing.scrbl | 3 +- collects/web-server/servlet.ss | 6 ++-- .../web-server/servlet/servlet-structs.ss | 2 +- collects/web-server/servlet/web.ss | 36 ++++++++++++------- 16 files changed, 108 insertions(+), 56 deletions(-) diff --git a/collects/tests/web-server/lang-test.ss b/collects/tests/web-server/lang-test.ss index a53a562217..dc41b4f683 100644 --- a/collects/tests/web-server/lang-test.ss +++ b/collects/tests/web-server/lang-test.ss @@ -200,12 +200,12 @@ ;; **************************************** ;; **************************************** - ;; TESTS INVOLVING send/suspend + ;; TESTS INVOLVING call-with-serializable-current-continuation (test-suite - "Tests Involving send/suspend" + "Tests Involving call-with-serializable-current-continuation" (test-case - "curried add with send/suspend" + "curried add with call-with-serializable-current-continuation" (let ([table-01-eval (make-module-eval (module table01 mzscheme @@ -227,7 +227,7 @@ (define (gn which) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "Please send the ~a number.~n" which)]) (store-k k)))))) @@ -248,7 +248,7 @@ (check-true (zero? (table-01-eval `(dispatch lookup-k '(,third-key 7)))))))) (test-case - "curried with send/suspend and serializaztion" + "curried with call-with-serializable-current-continuation and serializaztion" (let-values ([(test-m06.1) (make-module-eval @@ -256,7 +256,7 @@ (provide start) (define (gn which) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "Please send the ~a number.~n" which)]) k))))) @@ -275,7 +275,7 @@ (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7)))))))) (test-case - "curried with send/suspend and serializaztion (keyword args)" + "curried with call-with-serializable-current-continuation and serializaztion (keyword args)" (let-values ([(test-m06.2) (make-module-eval @@ -283,7 +283,7 @@ (provide start) (define (gn #:page which) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "Please send the ~a number.~n" which)]) k))))) @@ -373,14 +373,14 @@ (check-false (test-m07 '(dispatch-start start 7))))) (test-case - "send/suspend on rhs of letrec binding forms" + "call-with-serializable-current-continuation on rhs of letrec binding forms" (let-values ([(test-m08) (make-module-eval (module m08 (lib "lang.ss" "web-server") (provide start) (define (gn which) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "Please send the ~a number.~n" which)]) k))))) @@ -483,7 +483,7 @@ (check = 2 (ta-eval '(dispatch-start start 1))))) (test-case - "attempt send/suspend from standard call to map" + "attempt call-with-serializable-current-continuation from standard call to map" (let-values ([(m13-eval) (make-module-eval @@ -491,7 +491,7 @@ (provide start) (define (start initial) (map - (lambda (n) (send/suspend + (lambda (n) (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "n = ~s~n" n)]) k)))) @@ -500,7 +500,7 @@ (lambda () (m13-eval '(dispatch-start start 'foo))))))) (test-case - "attempt send/suspend from tail position of untranslated procedure" + "attempt call-with-serializable-current-continuation from tail position of untranslated procedure" (let-values ([(ta-eval) (make-module-eval @@ -517,7 +517,7 @@ (+ 1 (tail-apply (lambda (n) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "n = ~s~n" n)]) k))))) 7))))) diff --git a/collects/tests/web-server/lang/web-param-test.ss b/collects/tests/web-server/lang/web-param-test.ss index 072efce82d..19fc9646dc 100644 --- a/collects/tests/web-server/lang/web-param-test.ss +++ b/collects/tests/web-server/lang/web-param-test.ss @@ -41,7 +41,7 @@ (define (start ignore) (web-parameterize ([first 1] [second 2]) - (send/suspend (lambda (k) k)) + (call-with-serializable-current-continuation (lambda (k) k)) (+ (first) (second))))))]) (let ([first-key (meval '(dispatch-start start #f))]) (check = 3 (meval `(dispatch ,the-dispatch (list ,first-key #f)))))))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss index 8e647a261f..4573a4d94c 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss @@ -5,7 +5,7 @@ ;; get-number-from-user: string -> number ;; ask the user for a number (define (gn msg) - (send/suspend/dispatch + (send/suspend/url/dispatch (lambda (embed/url) `(hmtl (head (title ,(format "Get ~a number" msg))) (body diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/mm00.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/mm00.ss index 1603bdcb21..3c18220d35 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/mm00.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/mm00.ss @@ -4,7 +4,7 @@ (define (gn which) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "Please send the ~a number.~n" which)]) k))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/mm01.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/mm01.ss index 03e985be50..0445506300 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/mm01.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/mm01.ss @@ -4,7 +4,7 @@ (define (gn which) (cadr - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (let ([ignore (printf "Please send the ~a number.~n" which)]) k))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/wc-comp.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/wc-comp.ss index e91cd862a0..3bb5428823 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/wc-comp.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/wc-comp.ss @@ -11,7 +11,7 @@ (define include1 (include-counter counter1)) (define include2 (include-counter counter2)) ; counter1 and counter2 may have been modified - (send/suspend/dispatch + (send/suspend/url/dispatch (lambda (embed/url) ; The frame (ref) must have been captured, any changes to web-cells after this will be lost `(html diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/wc-fake.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/wc-fake.ss index 6df0482c72..82866fd6a3 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/wc-fake.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/wc-fake.ss @@ -5,7 +5,7 @@ (define (start initial-request) (define counter1 0) (define counter2 0) - (send/suspend/dispatch + (send/suspend/url/dispatch (lambda (embed/url) (let*-values ([(inc1 next-counter1 next-counter2) (include-counter counter1 counter2 embed/url)] [(inc2 next-counter2 next-counter1) (include-counter next-counter2 next-counter1 embed/url)]) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/wc.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/wc.ss index 7861468dd0..aa579bc1c4 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/wc.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/wc.ss @@ -10,7 +10,7 @@ (define include1 (include-counter counter1)) (define include2 (include-counter counter2)) ; counter1 and counter2 may have been modified - (send/suspend/dispatch + (send/suspend/url/dispatch (lambda (embed/url) ; The frame (ref) must have been captured, any changes to web-cells after this will be lost `(html diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index 02c18313fa..b805349e92 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -116,7 +116,7 @@ ;; send/suspend: (continuation -> response) -> request ;; produce the current response and wait for the next request -(define (send/suspend response-maker) +(define (call-with-serializable-current-continuation response-maker) (with-continuation-mark safe-call? '(#t send/suspend) (let ([current-marks (activation-record-list)] [wcs (capture-web-cell-set)]) @@ -189,4 +189,4 @@ (provide ;; "SERVLET" INTERFACE ; A contract would interfere with the safe-call? key - send/suspend) + call-with-serializable-current-continuation) diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index 87cfb2933e..1e63658bde 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -17,9 +17,11 @@ initialize-servlet ;; Servlet Interface + send/suspend + send/suspend/dispatch send/suspend/hidden send/suspend/url - send/suspend/dispatch) + send/suspend/url/dispatch) (provide/contract [make-stateless-servlet @@ -34,8 +36,8 @@ ;; Servlet Interface [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)] [send/suspend/url ((url? . -> . response/c) . -> . request?)] - [send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) - . -> . any/c)]) + [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) + . -> . any/c)]) ;; initial-servlet : (request -> response) -> (request -> response/c) (define (initialize-servlet start) @@ -55,7 +57,7 @@ ;; send/suspend/hidden: (url input-field -> response) -> request ;; like send/suspend except the continuation is encoded in a hidden field (define (send/suspend/hidden page-maker) - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (define stuffer (stateless-servlet-stuffer (current-servlet))) (define p-cont ((stuffer-in stuffer) k)) @@ -66,7 +68,7 @@ ;; send/suspend/url: (url -> response) -> request ;; like send/suspend except the continuation is encoded in the url (define (send/suspend/url page-maker) - (send/suspend + (call-with-serializable-current-continuation (lambda (k) (define stuffer (stateless-servlet-stuffer (current-servlet))) (page-maker @@ -74,15 +76,31 @@ (request-uri (execution-context-request (current-execution-context))) k))))) +(define (send/suspend page-maker) + (send/suspend/url + (lambda (k-url) + (page-maker (url->string k-url))))) + (define-closure embed/url (proc) (k) (stuff-url (stateless-servlet-stuffer (current-servlet)) (request-uri (execution-context-request (current-execution-context))) (kont-append-fun k proc))) -(define (send/suspend/dispatch response-generator) - (send/suspend +(define (send/suspend/url/dispatch response-generator) + (call-with-serializable-current-continuation (lambda (k) (response-generator (make-embed/url (lambda () k)))))) +; XXX Uncopy&paste +(define-closure embed (proc) (k) + (url->string + (stuff-url (stateless-servlet-stuffer (current-servlet)) + (request-uri (execution-context-request (current-execution-context))) + (kont-append-fun k proc)))) +(define (send/suspend/dispatch response-generator) + (call-with-serializable-current-continuation + (lambda (k) + (response-generator (make-embed (lambda () k)))))) + ;; request->continuation: req -> continuation ;; decode the continuation from the hidden field of a request (define (request->continuation req) diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index acc06bfd4d..d6a67ec56a 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -14,7 +14,7 @@ @(require (for-label web-server/lang/abort-resume)) @defmodule[web-server/lang/abort-resume]{ -@defproc[(send/suspend [response-generator (continuation? . -> . any)]) +@defproc[(call-with-serializable-current-continuation [response-generator (continuation? . -> . any)]) any]{ Captures the current continuation in a serializable way and calls @scheme[response-generator] with it, returning the result. } @@ -33,6 +33,11 @@ the response to the client. If the URL is invoked the request is returned to this continuation. } + +@defproc[(send/suspend [response-generator (string? . -> . response/c)]) + request?]{ + Like @scheme[send/suspend/url] but with a string URL representation. +} @defproc[(send/suspend/hidden [response-generator (url? xexpr/c . -> . response/c)]) request?]{ @@ -44,13 +49,18 @@ the request is returned to this continuation. } -@defproc[(send/suspend/dispatch [make-response (embed/url/c . -> . response/c)]) - any/c]{ +@defproc[(send/suspend/url/dispatch [make-response (((request? . -> . any) . -> . url?) . -> . response/c)]) + any]{ Calls @scheme[make-response] with a function that, when called with a procedure from @scheme[request?] to @scheme[any/c] will generate a URL, that when invoked will call the function with the @scheme[request?] object and return the result to the caller of @scheme[send/suspend/dispatch]. } + +@defproc[(send/suspend/dispatch [make-response (((request? . -> . any) . -> . string?) . -> . response/c)]) + request?]{ + Like @scheme[send/suspend/url/dispatch] but with a string URL representation. +} @deftogether[( @defproc[(redirect/get) request?] diff --git a/collects/web-server/scribblings/web.scrbl b/collects/web-server/scribblings/web.scrbl index 4c71fc6a22..2a17e61c52 100644 --- a/collects/web-server/scribblings/web.scrbl +++ b/collects/web-server/scribblings/web.scrbl @@ -4,7 +4,8 @@ @title[#:tag "web.ss"]{Web Interaction} @(require (for-label web-server/servlet/web web-server/servlet/servlet-structs - web-server/http)) + web-server/http + net/url)) @defmodule[web-server/servlet/web]{The @schememodname[web-server/servlet/web] library provides the primary @@ -25,8 +26,7 @@ functions of interest for the servlet developer. ] } -@defproc[(send/suspend [make-response response-generator/c] - [exp expiration-handler/c (current-servlet-continuation-expiration-handler)]) +@defproc[(send/suspend [make-response (string? . -> . response/c)]) request?]{ Captures the current continuation, stores it with @scheme[exp] as the expiration handler, and binds it to a URL. @scheme[make-response] is called with this URL and @@ -50,8 +50,13 @@ functions of interest for the servlet developer. Thus, the request will be ``returned'' from @scheme[send/suspend] to the continuation of this call. } -@defproc[(send/suspend/dispatch [make-response (embed/url/c . -> . response/c)]) - any/c]{ +@defproc[(send/suspend/url [make-response (url? . -> . response/c)]) + request?]{ + Like @scheme[send/suspend] but with a URL struct. +} + +@defproc[(send/suspend/dispatch [make-response (((request? . -> . any) . -> . string?) . -> . response/c)]) + any]{ Calls @scheme[make-response] with a function (@scheme[embed/url]) that, when called with a procedure from @scheme[request?] to @scheme[any/c] will generate a URL, that when invoked will call the function with the @scheme[request?] object and return the result to the caller of @@ -110,9 +115,13 @@ functions of interest for the servlet developer. "+"))))))) ] } + +@defproc[(send/suspend/url/dispatch [make-response (((request? . -> . any) . -> . url?) . -> . response/c)]) + any]{ + Like @scheme[send/suspend/dispatch], but with a URL struct. +} -@defproc[(send/forward [make-response response-generator/c] - [exp expiration-handler/c (current-servlet-continuation-expiration-handler)]) +@defproc[(send/forward [make-response (string? . -> . response/c)]) request?]{ Calls @scheme[clear-continuation-table!], then @scheme[send/suspend]. diff --git a/collects/web-server/scribblings/writing.scrbl b/collects/web-server/scribblings/writing.scrbl index fb3569a5af..9568fe1489 100644 --- a/collects/web-server/scribblings/writing.scrbl +++ b/collects/web-server/scribblings/writing.scrbl @@ -18,6 +18,7 @@ There are two API sets provided by the Web Server. One is for standard servlets, This API provides: @itemize{ + @item{@schememodname[net/url],} @item{@schememodname[web-server/servlet/web-cells],} @item{@schememodname[web-server/dispatch],} @item{@schememodname[web-server/http/bindings],} @@ -79,7 +80,7 @@ Example: @schemeblock[(lambda (req) } @defthing[embed/url/c contract?]{ -Equivalent to @scheme[(((request? . -> . any/c)) (expiration-handler/c) . opt-> . string?)]. +Equivalent to @scheme[((request? . -> . any) . -> . string?)]. This is what @scheme[send/suspend/dispatch] gives to its function argument. } diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 5a339fe525..58439e210a 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,11 +1,13 @@ #lang scheme/base -(require web-server/servlet/web-cells +(require net/url + web-server/servlet/web-cells web-server/http/bindings web-server/http web-server/dispatch web-server/servlet/servlet-structs web-server/servlet/web) -(provide (all-from-out web-server/servlet/web-cells +(provide (all-from-out net/url + web-server/servlet/web-cells web-server/http/bindings web-server/dispatch web-server/http diff --git a/collects/web-server/servlet/servlet-structs.ss b/collects/web-server/servlet/servlet-structs.ss index bfee8945f8..31dab8e1f4 100644 --- a/collects/web-server/servlet/servlet-structs.ss +++ b/collects/web-server/servlet/servlet-structs.ss @@ -13,7 +13,7 @@ (request? . -> . response/c))) (define embed/url/c - (((request? . -> . any/c)) (expiration-handler/c) . ->* . string?)) + ((request? . -> . any/c) . -> . string?)) (provide/contract [response-generator/c contract?] diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss index 16a1a7687c..06b0cb0bb1 100644 --- a/collects/web-server/servlet/web.ss +++ b/collects/web-server/servlet/web.ss @@ -42,9 +42,11 @@ [clear-continuation-table! (-> void?)] [send/back (response/c . -> . void?)] [send/finish (response/c . -> . void?)] - [send/suspend ((response-generator/c) (expiration-handler/c) . ->* . request?)] - [send/forward ((response-generator/c) (expiration-handler/c) . ->* . request?)] - [send/suspend/dispatch ((embed/url/c . -> . response/c) . -> . any/c)]) + [send/forward (response-generator/c . -> . request?)] + [send/suspend (response-generator/c . -> . request?)] + [send/suspend/dispatch ((embed/url/c . -> . response/c) . -> . any/c)] + [send/suspend/url ((url? . -> . response/c) . -> . request?)] + [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) . -> . any/c)]) ;; ************************************************************ ;; EXPORTS @@ -73,10 +75,9 @@ (clear-continuation-table!) (send/back resp)) -;; send/suspend: (url -> response) [(request -> response)] -> request +;; send/suspend: (url -> response) -> request ;; send a response and apply the continuation to the next request -(define (send/suspend response-generator - [expiration-handler (current-servlet-continuation-expiration-handler)]) +(define (send/suspend response-generator) (define wcs (capture-web-cell-set)) (begin0 (call-with-composable-continuation @@ -86,7 +87,7 @@ (define k-embedding ((manager-continuation-store! (current-servlet-manager)) instance-id (make-custodian-box (current-custodian) k) - expiration-handler)) + (current-servlet-continuation-expiration-handler))) (define k-url (embed-ids (list* instance-id k-embedding) (request-uri (execution-context-request ctxt)))) @@ -94,12 +95,16 @@ servlet-prompt) (restore-web-cell-set! wcs))) +(define (send/suspend/url response-generator) + (send/suspend + (lambda (k-url) + (response-generator (string->url k-url))))) + ;; send/forward: (url -> response) [(request -> response)] -> request ;; clear the continuation table, then behave like send/suspend -(define (send/forward response-generator - [expiration-handler (current-servlet-continuation-expiration-handler)]) +(define (send/forward response-generator) (clear-continuation-table!) - (send/suspend response-generator expiration-handler)) + (send/suspend response-generator)) ;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request ;; send/back a response generated from a procedure that may convert @@ -113,17 +118,24 @@ (lambda (k0) (send/back (response-generator - (lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) + (lambda (proc) (let/ec k1 ; This makes the second continuation captured by send/suspend smaller (call-with-continuation-prompt (lambda () - (let ([new-request (send/suspend k1 expiration-handler)]) + (let ([new-request (send/suspend k1)]) (k0 (lambda () (proc new-request))))) servlet-prompt)))))) servlet-prompt)]) (thunk))) +(define (send/suspend/url/dispatch response-generator) + (send/suspend/dispatch + (lambda (embed/url) + (response-generator + (lambda (proc) + (string->url (embed/url proc))))))) + ;; ************************************************************ ;; HIGHER-LEVEL EXPORTS