suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

compat

Browse Source 
svn: r13922
This commit is contained in:
Jay McCarthy 2009-03-03 20:02:31 +00:00
parent 089ebfe492
commit e1dab52b07
16 changed files with 108 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/tests/web-server/lang-test.ss
View File

@ -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)))))

2
collects/tests/web-server/lang/web-param-test.ss
View File

@ -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))))))))))

2
collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss
View File

@ -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

2
collects/web-server/default-web-root/htdocs/lang-servlets/mm00.ss
View File

@ -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)))))

2
collects/web-server/default-web-root/htdocs/lang-servlets/mm01.ss
View File

@ -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)))))

2
collects/web-server/default-web-root/htdocs/lang-servlets/wc-comp.ss
View File

@ -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

2
collects/web-server/default-web-root/htdocs/lang-servlets/wc-fake.ss
View File

@ -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)])

2
collects/web-server/default-web-root/htdocs/lang-servlets/wc.ss
View File

@ -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

4
collects/web-server/lang/abort-resume.ss
View File

@ -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)

32
collects/web-server/lang/web.ss
View File

@ -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)

16
collects/web-server/scribblings/lang.scrbl
View File

@ -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?]

23
collects/web-server/scribblings/web.scrbl
View File

@ -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].

3
collects/web-server/scribblings/writing.scrbl
View File

@ -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.
}

6
collects/web-server/servlet.ss
View File

@ -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

2
collects/web-server/servlet/servlet-structs.ss
View File

@ -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?]

36
collects/web-server/servlet/web.ss
View File

@ -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