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

Native continuations in serial language, soft state, and typos. Eli, this may be put into the release.

Browse Source 
svn: r14854
This commit is contained in:
Jay McCarthy 2009-05-18 17:46:15 +00:00
parent 7ef0e8258e
commit ac8aca7b21
33 changed files with 614 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/tests/web-server/dispatchers/dispatch-lang-test.ss
View File

@ -106,6 +106,16 @@
"add06.ss - send/suspend/dispatch"
(build-path example-servlets "add06.ss"))
(test-add-two-numbers
mkd
"add-native.ss - native continuation parts"
(build-path example-servlets "add-native.ss"))
(test-add-two-numbers
mkd
"add-soft.ss - soft state"
(build-path example-servlets "add-soft.ss"))
; XXX test something is not d-c
(test-double-counters
mkd
@ -153,3 +163,8 @@
; XXX test web-extras.ss - redirect/get
))
#|
(require schemeunit/text-ui)
(run-tests dispatch-lang-tests)
|#

68
collects/tests/web-server/lang/abort-resume-test.ss
View File

@ -169,8 +169,8 @@
(lambda ()
(let/ec esc
('f1 (with-continuation-mark the-cont-key +
(esc (activation-record-list)))))))
(list (vector + #f))))
(esc (reverse (activation-record-list))))))))
(list (vector + #f #f))))
(test-case
"Double"
@ -179,10 +179,10 @@
(let/ec esc
('f1 (with-continuation-mark the-cont-key +
('f2 (with-continuation-mark the-cont-key -
(esc (activation-record-list)))))))))
(esc (reverse (activation-record-list))))))))))
; Opposite the order of c-c-m
(list (vector + #f)
(vector - #f))))
(list (vector + #f #f)
(vector - #f #f))))
(test-case
"Unsafe"
@ -216,21 +216,21 @@
(check-equal? (resume empty (list 42))
42))
(test-case
#;(test-case
"Empty frame"
(check-exn exn? (lambda () (resume (list (vector #f #f)) (list 42)))))
(check-exn exn? (lambda () (resume (reverse (list (vector #f #f #f))) (list 42)))))
(test-case
"Kont"
(let ([f (lambda (x) (* x x))])
(check-equal? (resume (list (vector f #f)) (list 42))
(check-equal? (resume (reverse (list (vector f #f #f))) (list 42))
(f 42))))
(test-case
"Kont 2"
(let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))])
(check-equal? (resume (list (vector f #f) (vector g #f)) (list 42))
(check-equal? (resume (reverse (list (vector f #f #f) (vector g #f #f))) (list 42))
(f (g 42)))))
(test-case
@ -238,16 +238,17 @@
(let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))]
[esc-b (box #f)]
[capture (lambda _ (activation-record-list))])
[capture (lambda _ (reverse (activation-record-list)))])
(check-equal? (call-with-web-prompt
(lambda ()
(let/ec esc
(set-box! esc-b esc)
(resume (list (vector f #f) (vector g #f)
(vector esc #f) (vector capture #f))
(resume (reverse
(list (vector f #f #f) (vector g #f #f)
(vector esc #f #f) (vector capture #f #f)))
(list 42)))))
(list (vector f #f) (vector g #f)
(vector (unbox esc-b) #f)))))
(list (vector f #f #f) (vector g #f #f)
(vector (unbox esc-b) #f #f)))))
(test-case
"marks"
@ -256,14 +257,16 @@
(check-equal? (call-with-web-prompt
(lambda ()
(let/ec esc
(resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))))
(vector g (make-immutable-hash (list (cons 5 6))))
(vector esc (make-immutable-hash (list (cons 7 8))))
(vector (lambda _
(continuation-mark-set->list*
(current-continuation-marks)
(list 1 3 5 7)))
#f))
(resume (reverse
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
(vector g (make-immutable-hash (list (cons 5 6))) #f)
(vector esc (make-immutable-hash (list (cons 7 8))) #f)
(vector (lambda _
(continuation-mark-set->list*
(current-continuation-marks)
(list 1 3 5 7)))
#f
#f)))
(list 42)))))
(list (vector #f #f #f 8)
(vector #f #f 6 #f)
@ -279,14 +282,16 @@
(lambda ()
(let/ec esc
(set-box! esc-b esc)
(resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))))
(vector g (make-immutable-hash (list (cons 5 6))))
(vector esc (make-immutable-hash (list (cons 7 8))))
(vector capture #f))
(resume (reverse
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
(vector g (make-immutable-hash (list (cons 5 6))) #f)
(vector esc (make-immutable-hash (list (cons 7 8))) #f)
(vector capture #f #f)))
(list 42)))))
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))))
(vector g (make-immutable-hash (list (cons 5 6))))
(vector (unbox esc-b) (make-immutable-hash (list (cons 7 8)))))))))
(reverse
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
(vector g (make-immutable-hash (list (cons 5 6))) #f)
(vector (unbox esc-b) (make-immutable-hash (list (cons 7 8))) #f)))))))
; XXX test kont
@ -299,3 +304,8 @@
; XXX test dispatch
))
#|
(require schemeunit/text-ui)
(run-tests abort-resume-tests)
|#

34
collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss Normal file
View File

@ -0,0 +1,34 @@
#lang web-server
(require web-server/managers/lru)
(define interface-version 'stateless)
(define manager
(make-threshold-LRU-manager #f (* 1024 1024 128)))
(provide start manager interface-version)
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend/url
(lambda (k-url)
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "get"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"])))))))])
(string->number
(cdr (assoc 'number (url-query (request-uri req)))))))
(define (gn* m)
(first (serial->native (map (lambda (m) (native->serial (gn m))) (list m)))))
(define (start initial-request)
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn* "first") (gn* "second")))))))

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

@ -11,7 +11,7 @@
(send/suspend/url
(lambda (k-url)
(printf "ssu ~S~n" (msg))
`(hmtl (head (title ,(format "Get ~a number" (msg))))
`(html (head (title ,(format "Get ~a number" (msg))))
(body
(form ([action ,(url->string k-url)]
[method "post"]

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

@ -11,7 +11,7 @@
(send/suspend/url
(lambda (k-url)
(printf "ssu ~S~n" (msg))
`(hmtl (head (title ,(format "Get ~a number" (msg))))
`(html (head (title ,(format "Get ~a number" (msg))))
(body
(form ([action ,(url->string k-url)]
[method "post"]

31
collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss Normal file
View File

@ -0,0 +1,31 @@
#lang web-server
(define interface-version 'stateless)
(provide start interface-version)
(define softie
(soft-state
"submit"))
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend/url
(lambda (k-url)
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "get"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type ,(soft-state-ref softie)])))))))])
(string->number
(cdr (assoc 'number (url-query (request-uri req)))))))
(define (start initial-request)
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn "first") (gn "second")))))))

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

@ -12,7 +12,7 @@
(send/suspend/url
(lambda (k-url)
(printf "ssu~n")
`(hmtl (head (title ,(format "Get ~a number" msg)))
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "post"]

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

@ -8,7 +8,7 @@
(let ([req
(send/suspend/url
(lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "get"]

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

@ -8,7 +8,7 @@
(let ([req
(send/suspend/hidden
(lambda (ses-url k-hidden)
`(hmtl (head (title ,(format "Get ~a number" msg)))
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string ses-url)]
[method "post"]

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

@ -12,7 +12,7 @@
(let ([req
(send/suspend/url
(lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "post"]

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

@ -8,7 +8,7 @@
(let ([req
(send/suspend/url
(lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "post"]

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

@ -7,7 +7,7 @@
(define (gn msg)
(send/suspend/url/dispatch
(lambda (embed/url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string
(embed/url

43
collects/web-server/default-web-root/htdocs/lang-servlets/map.ss Normal file
View File

@ -0,0 +1,43 @@
#lang web-server
(require web-server/managers/lru)
(define-native (build-list/native _ ho) build-list)
(define interface-version 'stateless)
(define manager
(make-threshold-LRU-manager #f (* 1024 1024 128)))
(provide start interface-version manager)
;; get-number-from-user: number -> number
;; ask the user for a number
(define (get-number-from-user message)
(let ([req
(send/suspend/url
(lambda (k-url)
`(html (head (title ,message))
(body
(form ([action ,(url->string k-url)]
[method "post"]
[enctype "application/x-www-form-urlencoded"])
,message
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"])))))))])
(string->number
(bytes->string/utf-8
(binding:form-value
(bindings-assq #"number"
(request-bindings/raw req)))))))
(define (start initial-request)
(define how-many-numbers
(get-number-from-user "How many numbers do you want to add?"))
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(apply +
(build-list/native how-many-numbers
(lambda (i)
(get-number-from-user
(format "Enter number ~a" (add1 i)))))))))))

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

@ -24,7 +24,7 @@
;; generate the page for the question
(define (make-cue-page mc-q)
(lambda (ses-url k-hidden)
`(hmtl (head (title "Question"))
`(html (head (title "Question"))
(body
(form ([action ,(url->string ses-url)] [method "post"]
[enctype "application/x-www-form-urlencoded"])

17
collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss Normal file
View File

@ -0,0 +1,17 @@
#lang web-server
(provide interface-version start)
(define interface-version 'stateless)
(define softie
(soft-state
(printf "Doing a long computation...~n")
(sleep 1)
5))
(define (start req)
(soft-state-ref softie)
(printf "Done~n")
(start
(send/suspend
(lambda (k-url)
`(html (body (a ([href ,k-url]) "Done")))))))

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

@ -1,7 +1,9 @@
#lang scheme
(require scheme/serialize
"../private/define-closure.ss"
"../lang/web-cells.ss")
web-server/private/servlet
web-server/managers/manager
web-server/private/define-closure
web-server/lang/web-cells)
;; **********************************************************************
;; **********************************************************************
@ -12,6 +14,8 @@
(define safe-call? (make-mark-key))
(define web-prompt (make-continuation-prompt-tag 'web))
(define empty-hash
(make-immutable-hash empty))
(define (with-current-saved-continuation-marks-and key val thnk)
(call-with-immediate-continuation-mark
the-save-cm-key
@ -19,27 +23,34 @@
(with-continuation-mark the-save-cm-key
(hash-set old-cms key val)
(thnk)))
(make-immutable-hash empty)))
empty-hash))
;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation
(define (activation-record-list)
(let* ([cm (current-continuation-marks web-prompt)]
[sl (continuation-mark-set->list cm safe-call?)])
(if (andmap (lambda (x)
(if (pair? x)
(car x)
x))
sl)
(begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm)
#;(printf "CMs: ~S~n" (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key)))
(reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))))
; XXX call this once with a non-#f default
[sl (continuation-mark-set->list* cm (list safe-call? continuation-of-unsafe-part-mark))])
(if (calling-context-okay? sl #f)
(store-unsafe-parts-on-server! (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key continuation-of-unsafe-part-mark)))
(error "Attempt to capture a continuation from within an unsafe context:" sl))))
;; calling-context-okay? : (listof (vector safe-call? unsafe-continuation-mark)) -> boolean
(define (calling-context-okay? ctxt native-above?)
(match ctxt
[(list) #t]
[(list-rest (vector (or (list-rest safe-call? _)
safe-call?)
unsafe-part)
more-ctxt)
(and (or native-above? safe-call?)
(calling-context-okay?
more-ctxt
(or unsafe-part native-above?)))]))
;; abort: ( -> alpha) -> alpha
;; erase the stack and apply a thunk
(define (abort thunk)
#;(printf "abort ~S~n" thunk)
(define (abort thunk)
(abort-current-continuation web-prompt thunk))
;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3
@ -55,25 +66,43 @@
(hash-map cms cons)
thnk))
;; resume: (listof (value -> value)) value -> value
;; resume*: (listof (value -> value)) value -> value
;; resume a computation given a value and list of frame procedures
(define (resume frames val)
(define (resume* frames val)
#;(printf "~S~n" `(resume ,frames ,val))
(match frames
[(list)
#;(printf "Returning value ~S~n" val)
(apply values val)]
[(list-rest f fs)
(match f
[(vector #f #f)
(error 'resume "Empty frame")]
[(vector f #f)
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
[(list-rest frame fs)
#;(printf "Frame ~S~n" frame)
(match frame
[(vector #f #f #f)
; XXX Perhaps I should err?
#;(error 'resume "Empty frame")
(resume* fs val)]
[(vector f #f #f)
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume* fs val)))
f)]
[(vector #f cms)
[(vector #f cms #f)
(with-continuation-mark the-save-cm-key cms
(with-continuation-marks/hash cms (lambda () (resume fs val))))]
[(vector f cms)
(resume (list* (vector f #f) (vector #f cms) fs) val)])]))
(with-continuation-marks/hash cms (lambda () (resume* fs val))))]
[(vector #f #f nkpt-label)
(serial->native
((get-unsafe-part-from-server nkpt-label)
(with-continuation-mark continuation-of-unsafe-part-mark nkpt-label
(resume* fs val))))]
[(vector f cms nkpt-label)
(resume* (list* (vector f #f #f)
(vector #f cms #f)
(if nkpt-label
(list* (vector #f #f nkpt-label)
fs)
fs))
val)])]))
(define (resume frames val)
(resume* (reverse frames) val))
;; rebuild-cms : frames (-> value) -> value
(define (rebuild-cms frames thunk)
@ -81,11 +110,11 @@
(match frames
[(list)
(thunk)]
[(list-rest f fs)
(match f
[(vector f #f)
[(list-rest frame fs)
(match (vector-ref frame 1)
[#f
(rebuild-cms fs thunk)]
[(vector f cms)
[cms
(with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])]))
(define (call-with-web-prompt thunk)
@ -111,20 +140,54 @@
(define-values (wcs current-marks) ((kont-env k)))
(make-kont
(lambda ()
(values wcs
(append current-marks (list (vector f #f)))))))
(values wcs (list* (vector f #f #f) current-marks)))))
;; send/suspend: (continuation -> response) -> request
;; produce the current response and wait for the next request
(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)])
((lambda (k)
(abort (lambda ()
; Since we escaped from the previous context, we need to re-install the user's continuation-marks
(rebuild-cms current-marks (lambda () (response-maker k))))))
(make-kont (lambda () (values wcs current-marks)))))))
(let* ([current-marks (activation-record-list)]
[wcs (capture-web-cell-set)]
[k (make-kont (lambda () (values wcs current-marks)))])
(abort (lambda ()
; Since we escaped from the previous context, we need to re-install the user's continuation-marks
(rebuild-cms (reverse current-marks) (lambda () (response-maker k))))))))
;; combining native and transformed continuations
(define unsafe-barrier-prompt-tag (make-continuation-prompt-tag 'unsafe))
(define continuation-of-unsafe-part-mark (make-mark-key))
(define (store-unsafe-part-on-server! k)
((manager-continuation-store! (current-servlet-manager))
(current-servlet-instance-id) k #f))
(define (get-unsafe-part-from-server k-label)
(apply (manager-continuation-lookup (current-servlet-manager))
(current-servlet-instance-id) k-label))
(define store-unsafe-parts-on-server!
(match-lambda
[(list) empty]
[(list-rest (vector f cms unsafe-part) ctxt)
(list* (vector f cms
(if unsafe-part
(store-unsafe-part-on-server! unsafe-part)
#f))
(store-unsafe-parts-on-server! ctxt))]))
(define-syntax-rule (serial->native f)
(serial->native* (lambda () f)))
(define-syntax-rule (native->serial f)
(native->serial* (lambda () f)))
(define (serial->native* thnk)
(call-with-continuation-prompt thnk unsafe-barrier-prompt-tag))
(define (native->serial* thnk)
(call-with-current-continuation
(lambda (unsafe-continuation-portion)
(with-continuation-mark
continuation-of-unsafe-part-mark unsafe-continuation-portion
(thnk)))
unsafe-barrier-prompt-tag))
;; **********************************************************************
;; **********************************************************************
@ -162,7 +225,8 @@
(define saved-context?
(listof (vector/c (or/c false/c procedure?)
(or/c false/c cms?))))
(or/c false/c cms?)
(or/c false/c symbol?))))
(provide/contract
;; AUXILLIARIES
@ -176,7 +240,7 @@
[activation-record-list (-> saved-context?)]
[with-current-saved-continuation-marks-and (any/c any/c (-> any/c) . -> . any/c)]
[kont-append-fun (kont? procedure? . -> . kont?)]
;; "CLIENT" INTERFACE
[dispatch ((request? . -> . (request? . -> . response?))
request?
@ -189,4 +253,6 @@
(provide
;; "SERVLET" INTERFACE
; A contract would interfere with the safe-call? key
native->serial
serial->native
call-with-serializable-current-continuation)

1
collects/web-server/lang/elim-callcc.ss
View File

@ -88,6 +88,7 @@
(#,cm)
(#%plain-lambda #,x
(#%plain-app abort
; XXX Do I need to rebuild the CMs?
(#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x)))))
(#%plain-app activation-record-list))))))]
[(#%plain-app call-with-values (#%plain-lambda () prod) cons)

8
collects/web-server/lang/lang-api.ss
View File

@ -6,9 +6,11 @@
web-server/stuffers
web-server/lang/abort-resume
web-server/lang/web
web-server/lang/native
web-server/lang/web-cells
web-server/lang/web-param
web-server/lang/file-box)
web-server/lang/file-box
web-server/lang/soft)
(provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url
web-server/http
@ -17,6 +19,8 @@
web-server/stuffers
web-server/lang/abort-resume
web-server/lang/web
web-server/lang/native
web-server/lang/web-cells
web-server/lang/web-param
web-server/lang/file-box))
web-server/lang/file-box
web-server/lang/soft))

25
collects/web-server/lang/native.ss Normal file
View File

@ -0,0 +1,25 @@
#lang scheme
(require web-server/lang/abort-resume
(for-syntax scheme))
(define-syntax (define-native stx)
(syntax-case stx ()
[(_ (id . argspec) original)
(quasisyntax/loc stx
(define id
(lambda id-args
(serial->native
(apply original
(map (lambda (higher-order? arg)
(if higher-order?
(lambda arg-args
(native->serial (apply arg arg-args)))
arg))
(list #,@(map (lambda (arg)
(syntax-case arg (ho)
[ho #t]
[_ #f]))
(syntax->list #'argspec)))
id-args))))))]))
(provide define-native)

33
collects/web-server/lang/soft.ss Normal file
View File

@ -0,0 +1,33 @@
#lang scheme
(require scheme/serialize)
(define-serializable-struct soft-state-record (id thnk))
(define *soft-state-cache*
(make-weak-hasheq))
(define next-record-id!
(local [(define record-id 0)]
(lambda ()
(begin0 record-id
(set! record-id (add1 record-id))))))
(define (make-soft-state thnk)
(make-soft-state-record (next-record-id!) thnk))
(define soft-state-ref
(match-lambda
[(struct soft-state-record (id thnk))
(hash-ref! *soft-state-cache* id thnk)]))
(define soft-state? soft-state-record?)
(define-syntax-rule (soft-state expr ...)
(make-soft-state (lambda () expr ...)))
(provide
soft-state)
(provide/contract
[soft-state? (any/c . -> . boolean?)]
[make-soft-state ((-> any/c) . -> . soft-state?)]
[soft-state-ref (soft-state? . -> . any/c)])

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

@ -81,25 +81,23 @@
(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-closure embed/url (proc) (k string?)
(let ([url
(stuff-url (stateless-servlet-stuffer (current-servlet))
(request-uri (execution-context-request (current-execution-context)))
(kont-append-fun k proc))])
(if string?
(url->string url)
url)))
(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))))
(response-generator (make-embed/url (lambda () (values k #f)))))))
(define (send/suspend/dispatch response-generator)
(call-with-serializable-current-continuation
(lambda (k)
(response-generator (make-embed (lambda () k))))))
(response-generator (make-embed/url (lambda () (values k #t)))))))
;; request->continuation: req -> continuation
;; decode the continuation from the hidden field of a request

1
collects/web-server/scribblings/dummy-stateless-servlet.ss
View File

@ -2,6 +2,7 @@
(define interface-version #f)
(define stuffer #f)
(define manager #f)
(define start #f)
(provide (all-defined-out))

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

@ -11,8 +11,10 @@ A stateless servlet should @scheme[provide] the following exports:
@(require (for-label web-server/http
scheme/serialize
web-server/stuffers
(except-in "dummy-stateless-servlet.ss" stuffer))) @; to give a binding context
(except-in web-server/stuffers stuffer)
web-server/managers/none
(except-in web-server/managers/manager manager)
"dummy-stateless-servlet.ss")) @; to give a binding context
@declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)]
@defthing[interface-version (one-of/c 'stateless)]{
@ -20,11 +22,17 @@ A stateless servlet should @scheme[provide] the following exports:
}
@defthing[stuffer (stuffer/c serializable? bytes?)]{
This is the @scheme[stuffer] that will be used for the servlet.
This is the stuffer that will be used for the servlet.
If it is not provided, it defaults to @scheme[default-stuffer].
}
@defthing[manager manager?]{
This is the manager that will be used for the servlet.
If it is not provided, it defaults to @scheme[(create-none-manager #f)].
}
@defproc[(start [initial-request request?])
response/c]{
This function is called when an instance of this servlet is started.
@ -34,6 +42,7 @@ A stateless servlet should @scheme[provide] the following exports:
An example @scheme['stateless] servlet module:
@schememod[
web-server
(provide interface-version stuffer start)
(define interface-version 'stateless)
(define stuffer
(stuffer-chain
@ -46,14 +55,18 @@ An example @scheme['stateless] servlet module:
These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http],
@schememodname[web-server/http/bindings],
@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/web-param],
@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and
@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/native],
@schememodname[web-server/lang/web-param],
@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/lang/soft], @schememodname[web-server/dispatch], and
@schememodname[web-server/stuffers].
Some of these are documented in the subsections that follow.
@include-section["serial.scrbl"]
@include-section["native.scrbl"]
@include-section["lang.scrbl"]
@include-section["lang-web-cells.scrbl"]
@include-section["file-box.scrbl"]
@include-section["web-param.scrbl"]
@include-section["soft.scrbl"]
@include-section["stuffers.scrbl"]
@include-section["stateless-usage.scrbl"]

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

@ -5,25 +5,10 @@
@(require (for-label net/url
xml
scheme/serialize
web-server/servlet/servlet-structs
web-server/lang/web
scheme
web-server/http))
@section{Low Level}
@(require (for-label web-server/lang/abort-resume))
@defmodule[web-server/lang/abort-resume]{
@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.
}
}
@section{High Level}
@(require (for-label web-server/lang/web))
@defmodule[web-server/lang/web]{
@defproc[(send/suspend/url [response-generator (url? . -> . response/c)])

36
collects/web-server/scribblings/native.scrbl Normal file
View File

@ -0,0 +1,36 @@
#lang scribble/doc
@(require "web-server.ss")
@title[]{Native Interfaces}
@(require (for-label scheme
web-server/lang/native
web-server/lang/abort-resume))
@defmodule[web-server/lang/native]{
It is sometimes inconvenient to use @scheme[serial->native] and @scheme[native->serial] throughout your program.
This module provides a macro for creating wrappers.
@defform[#:literals (ho) (define-native (native arg-spec ...) original) #:contracts ([arg-spec ho] [arg-spec _])]{
Builds an interface around @scheme[original] named @scheme[native] such that calls to @scheme[native] are wrapped in @scheme[serial->native]
and all arguments marked with @scheme[ho] in @scheme[arg-spec] are assumed to procedures and are wrapped in @scheme[native->serial].
For example,
@schemeblock[
(define-native (build-list/native _ ho) build-list)
]
is equivalent to
@schemeblock[
(define (build-list/native fst snd)
(serial->native
(build-list
fst
(lambda args
(native->serial
(apply snd args))))))
]
}
}

57
collects/web-server/scribblings/serial.scrbl Normal file
View File

@ -0,0 +1,57 @@
#lang scribble/doc
@(require "web-server.ss")
@title[]{Serializable Continuations}
@(require (for-label web-server/lang/abort-resume
"dummy-stateless-servlet.ss"
scheme/serialize))
@defmodule[web-server/lang/abort-resume]{
The main purpose of the stateless language is to provide serializable continuations to your servlet.
@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.
This potentially uses resources of the current servlet's @scheme[manager] if @scheme[serial->native] and @scheme[native->serial] were used
to capture an untransformable context.
}
@defform[(serial->native expr)]{
@scheme[serial->native] informs the serializing runtime that @scheme[expr] is potentially a call to an untransformed context.
This sets up the necessary information for
@scheme[native->serial] to signal to @scheme[call-with-serializable-current-continuation] to capture the native (and thus unserializable) section
of the context and store it on the server.
}
@defform[(native->serial expr)]{
@scheme[native->serial] informs the serializing runtime that @scheme[expr] marks first expression after returning from an untransformed context.
This captures the
untransformed context such that @scheme[call-with-serializable-current-continuation] can store it on the server and reference it from serializable
continuations.
For example,
@schemeblock[
(build-list
3
(lambda (i)
(call-with-serializable-current-continuation
(lambda (k) (serialize k)))))
]
will fail at runtime because @scheme[build-list] is not transformed. However,
@schemeblock[
(serial->native
(build-list
3
(lambda (i)
(native->serial
(call-with-serializable-current-continuation
(lambda (k) (serialize k)))))))
]
will succeed and @scheme[k] will reference a cell in the current servlet's @scheme[manager] that stores the part of the continuation in
@scheme[build-list].
}
}

4
collects/web-server/scribblings/servlet-setup.scrbl
View File

@ -27,9 +27,11 @@ This module is used internally to build and load servlets. It may be useful to t
}
@defproc[(make-stateless.servlet [directory path-string?]
[stuffer (stuffer/c serializable? bytes?)]
[manager manager?]
[start (request? . -> . response/c)])
servlet?]{
Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler.
Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory, @scheme[stuffer] as its stuffer, and @scheme[manager] as the continuation manager, and @scheme[start] as the request handler.
}
@defthing[default-module-specs (listof module-path?)]{

1
collects/web-server/scribblings/servlet.scrbl
View File

@ -33,6 +33,7 @@ An example version 2 module:
@schememod[
scheme
(require web-server/managers/none)
(provide interface-version manager start)
(define interface-version 'v2)
(define manager

71
collects/web-server/scribblings/soft.scrbl Normal file
View File

@ -0,0 +1,71 @@
#lang scribble/doc
@(require "web-server.ss"
(for-label web-server/lang/soft
web-server/lang/web))
@title[]{Soft State}
@defmodule[web-server/lang/soft]{
Sometimes you want to reference a large data-structure from a stateless program without the data-structure being serialized
and increasing the size of the serialization. This module provides support for this scenario.
@defproc[(soft-state? [v any/c])
boolean?]{
Determines if @scheme[v] is a soft state record.
}
@defproc[(make-soft-state [thnk (-> any/c)])
soft-state?]{
Creates a piece of soft state that is computed by @scheme[thnk]. This value is serializable.
}
@defproc[(soft-state-ref [ss soft-state?])
any/c]{
Extracts the value associated with @scheme[ss]. If the value is not available (perhaps because of garbage collection, deserialization in an uninitialized process, etc), then the thunk associated with @scheme[ss] is invoked and the value is cached.
}
@defform[(soft-state expr ...)]{
Equivalent to @scheme[(make-soft-state (lambda () expr ...))].
}
Here's an example servlet that uses soft state:
@schememod[
web-server
(provide interface-version start)
(define interface-version 'stateless)
(define softie
(soft-state
(printf "Doing a long computation...~n")
(sleep 1)))
(define (start req)
(soft-state-ref softie)
(printf "Done~n")
(start
(send/suspend
(lambda (k-url)
`(html (body (a ([href ,k-url]) "Done")))))))
]
When this is run and the link is clicked a few times, the output is:
@verbatim{
$ plt-web-server -p 8080
Doing a long computation...
Done
Done
Done
Done
}
If the server is restarted or the hostname in the URL is changed to a different host with the same code, and the URL is clicked:
@verbatim{
^Cuser break
$ plt-web-server -p 8080
Doing a long computation...
Done
}
}

47
collects/web-server/scribblings/stateless-usage.scrbl
View File

@ -1,22 +1,25 @@
#lang scribble/doc
@(require "web-server.ss")
@(require "web-server.ss"
(for-label scheme/serialize
web-server/lang/abort-resume
web-server/lang/web))
@title[#:tag "considerations"]{Usage Considerations}
A servlet has the following process performed on it automatically:
A stateless servlet has the following process performed on it automatically:
@itemize[
@item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of
@scheme[let] and imperative features.}
@item{The program is converted into ANF (Administrative Normal Form),
@item{The program is converted into @link["http://en.wikipedia.org/wiki/Administrative_normal_form"]{ANF} (Administrative Normal Form),
making all continuations explicit.}
@item{All continuations (and other continuations marks) are recorded in the
@item{All continuations and continuations marks are recorded in the
continuation marks of the expression
they are the continuation of.}
@item{All calls to external modules are identified and marked.}
@item{All uses of @scheme[call/cc] are removed and replaced with
equivalent gathering of the continuations through the continuation-marks.}
equivalent gathering of the continuations through the continuation marks installed earlier.}
@item{The program is defunctionalized with a serializable data-structure for each
anonymous lambda.}
@scheme[lambda].}
]
This process allows the continuations captured by your servlet to be serialized.
@ -24,21 +27,21 @@ This means they may be stored on the client's browser or the server's disk.
Thus, your servlet has no cost to the server other than execution. This is
very attractive if you've used Scheme servlets and had memory problems.
This process IS defined on all of PLT Scheme and occurs AFTER macro-expansion,
This process is defined on all of PLT Scheme and occurs after macro-expansion,
so you are free to use all interesting features of PLT Scheme. However, there
are some considerations you must make.
First, this process drastically changes the structure of your program. It
will create an immense number of lambdas and structures your program
did not normally contain. The performance implication of this has not been
studied with PLT Scheme. However, it is theoretically a benefit. The main
implications would be due to optimizations MzScheme attempts to perform
that will no longer apply. Ideally, your program should be optimized first.
studied with PLT Scheme.
Second, the defunctionalization process is sensitive to the syntactic structure
of your program. Therefore, if you change your program in a trivial way, for example,
changing a constant, then all serialized continuations will be obsolete and will
error when deserialization is attempted. This is a feature, not a bug!
error when deserialization is attempted. This is a feature, not a bug! It is a small
price to pay for protection from the sorts of errors that would occur if your program
were changed in a meaningful way.
Third, the values in the lexical scope of your continuations must be serializable
for the continuations itself to be serializable. This means that you must use
@ -47,7 +50,7 @@ care to use modules that do the same. Similarly, you may not use @scheme[paramet
because parameterizations are not serializable.
Fourth, and related, this process only runs on your code, not on the code you
@scheme[require]. Thus, your continuations---to be capturable---must not
@scheme[require]. Thus, your continuations---to be serializable---must not
be in the context of another module. For example, the following will not work:
@schemeblock[
(define requests
@ -55,12 +58,22 @@ be in the context of another module. For example, the following will not work:
response-generators))
]
because @scheme[map] is not transformed by the process. However, if you defined
your own @scheme[map] function, there would be no problem.
your own @scheme[map] function, there would be no problem. Another solution is to
store the @scheme[map] part of the continuation on the server with @scheme[serial->native]
and @scheme[native->serial]:
@schemeblock[
(define requests
(serial->native
(map (lambda (rg) (native->serial (send/suspend/url rg)))
response-generators)))
]
Fifth, the store is NOT serialized. If you rely on the store you will
Fifth, the store is @bold{not} serialized. If you rely on the store you will
be taking huge risks. You will be assuming that the serialized continuation
is invoked before the server is restarted or the memory is garbage collected.
is invoked on the same server before the server is restarted or
the memory is garbage collected.
This process is derived from the paper
@href-link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/" "Continuations from Generalized Stack Inspection"].
This process is derived from the ICFP papers
@emph{@link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/"]{Continuations from Generalized Stack Inspection}} by Pettyjohn et al. in 2005 and
@emph{Automatically RESTful Web Applications, Or Marking Modular Serializable Continuations} by Jay McCarthy in 2009.
We thank Greg Pettyjohn for his initial implementation of this algorithm.

20
collects/web-server/scribblings/stuffers.scrbl
View File

@ -49,22 +49,22 @@ You can supply your own (built with these functions) when you write a stateless
The identitiy @tech{stuffer}.
}
@defproc[(stuffer-compose [g (stuffer any/c any/c)]
[f (stuffer any/c any/c)])
(stuffer any/c any/c)]{
@defproc[(stuffer-compose [g (stuffer/c any/c any/c)]
[f (stuffer/c any/c any/c)])
(stuffer/c any/c any/c)]{
Composes @scheme[f] and @scheme[g], i.e., applies @scheme[f] then @scheme[g] for @scheme[in]
and @scheme[g] then @scheme[f] for @scheme[out].
}
@defproc[(stuffer-sequence [f (stuffer any/c any/c)]
[g (stuffer any/c any/c)])
(stuffer any/c any/c)]{
@defproc[(stuffer-sequence [f (stuffer/c any/c any/c)]
[g (stuffer/c any/c any/c)])
(stuffer/c any/c any/c)]{
@scheme[stuffer-compose] with arguments swapped.
}
@defproc[(stuffer-if [c (bytes? . -> . boolean?)]
[f (stuffer bytes? bytes?)])
(stuffer bytes? bytes?)]{
[f (stuffer/c bytes? bytes?)])
(stuffer/c bytes? bytes?)]{
Creates a @tech{stuffer} that stuffs with @scheme[f] if @scheme[c] is true on the input
to @scheme[in]. Similarly, applies @scheme[f] during @scheme[out] if it was applied during
@scheme[in] (which is recorded by prepending a byte.)
@ -140,7 +140,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value
]
}
It should be easy to use this interface to create store for databases, like SQLite, CouchDB, or BerkeleyDB.
It should be easy to use this interface to create store for databases like SQLite, CouchDB, or BerkeleyDB.
}
@section{Hash-addressed Storage}
@ -201,7 +201,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value
@defproc[(is-url-too-big? [v bytes?])
boolean?]{
Determines if stuffing @scheme[v] into the current servlet's URL would result in a URL that is too big for Internet Explorer.
(@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.}).
(@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.})
}
@defproc[(make-default-stuffer [root path-string?])

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

@ -2,7 +2,8 @@
@(require "web-server.ss")
@title[#:tag "web-cells.ss"]{Web Cells}
@(require (for-label web-server/servlet/web-cells))
@(require (for-label web-server/servlet/web-cells
web-server/servlet/web))
@defmodule[web-server/servlet/web-cells]{The
@schememodname[web-server/servlet/web-cells] library provides the

16
collects/web-server/servlet/setup.ss
View File

@ -67,15 +67,18 @@
(parameterize ([current-servlet-instance-id instance-id])
(handler req))))))
(define (make-stateless.servlet directory stuffer start)
(define (make-stateless.servlet directory stuffer manager start)
(define instance-id
((manager-create-instance manager) (exit-handler)))
(define ses
(make-stateless-servlet
(current-custodian) (current-namespace)
(create-none-manager (lambda (req) (error "No continuations!")))
manager
directory
(lambda (req) (error "Session not initialized"))
stuffer))
(parameterize ([current-directory directory]
[current-servlet-instance-id instance-id]
[current-servlet ses])
(set-servlet-handler! ses (initialize-servlet start)))
ses)
@ -110,7 +113,7 @@
(provide/contract
[make-v1.servlet (path-string? integer? (request? . -> . response/c) . -> . servlet?)]
[make-v2.servlet (path-string? manager? (request? . -> . response/c) . -> . servlet?)]
[make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) (request? . -> . response/c) . -> . servlet?)]
[make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) manager? (request? . -> . response/c) . -> . servlet?)]
[default-module-specs (listof (or/c resolved-module-path? module-path?))])
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
@ -163,11 +166,16 @@
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))]
[manager (contract manager?
(dynamic-require module-name 'manager
(lambda () (create-none-manager (lambda (req) (error "No continuations!")))))
pos-blame neg-blame
(mk-loc "manager"))]
[stuffer (contract (stuffer/c serializable? bytes?)
(dynamic-require module-name 'stuffer (lambda () default-stuffer))
pos-blame neg-blame
(mk-loc "stuffer"))])
(make-stateless.servlet (directory-part a-path) stuffer start))]))]
(make-stateless.servlet (directory-part a-path) stuffer manager start))]))]
[else
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda