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

Fixing web parameter bug

Browse Source 
svn: r6337
This commit is contained in:
Jay McCarthy 2007-05-26 06:05:57 +00:00
parent e38400b495
commit 0a07ed3b18
5 changed files with 95 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -152,7 +152,7 @@
conn
(responders-servlet (request-uri req) the-exn)
(request-method req)))])
(printf "session-handler ~S~n" (session-handler ses))
#;(printf "session-handler ~S~n" (session-handler ses))
(output-response conn
((session-handler ses) req)))))]
[else

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

@ -86,7 +86,9 @@
(markit
(quasisyntax/loc stx
(with-continuation-mark #,ke-prime #,me-prime
(with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime)
(with-continuation-mark
the-save-cm-key
(#%app current-saved-continuation-marks-and #,ke-prime #,me-prime)
#,be-prime)))))]
[(#%expression . d)
stx]

36
collects/web-server/prototype-web-server/private/abort-resume.ss
View File

@ -1,5 +1,6 @@
(module abort-resume mzscheme
(require "define-closure.ss"
(lib "list.ss")
(lib "plt-match.ss")
(lib "serialize.ss")
"../lang-api/web-cells.ss")
@ -13,6 +14,7 @@
safe-call?
the-undef
activation-record-list
current-saved-continuation-marks-and
;; "SERVLET" INTERFACE
start-interaction
@ -32,6 +34,15 @@
(define safe-call? (make-mark-key))
(define web-prompt (make-continuation-prompt-tag 'web))
(define (current-saved-continuation-marks-and key val)
(reverse
(list* (cons key val)
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks) the-save-cm-key)])
(if (empty? current)
empty
(first current))))))
;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation
(define (activation-record-list)
@ -43,14 +54,14 @@
x))
sl)
(begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm)
#;(printf "MSG CMs: ~S~n" (continuation-mark-set->list* cm (list 'msg the-cont-key the-save-cm-key)))
#;(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))))
(error "Attempt to capture a continuation from within an unsafe context:" sl))))
;; abort: ( -> alpha) -> alpha
;; erase the stack and apply a thunk
(define (abort thunk)
(printf "abort ~S~n" thunk)
#;(printf "abort ~S~n" thunk)
(abort-current-continuation web-prompt thunk))
;; resume: (listof (value -> value)) value -> value
@ -67,10 +78,16 @@
[(vector f #f)
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
f)]
[(vector #f (list-rest cm-key cm-val))
(with-continuation-mark the-save-cm-key (cons cm-key cm-val)
[(vector #f (list))
(resume fs val)]
[(vector #f (list-rest (list-rest cm-key cm-val) cms))
(with-continuation-mark
the-save-cm-key
(current-saved-continuation-marks-and cm-key cm-val)
(with-continuation-mark cm-key cm-val
(resume fs val)))]
(begin
#;(printf "r: w-c-m ~S ~S~n" cm-key cm-val)
(resume (list* (vector #f cms) fs) val))))]
[(vector f cm)
(resume (list* (vector f #f) (vector #f cm) fs) val)])]))
@ -84,8 +101,13 @@
(match f
[(vector f #f)
(rebuild-cms fs thunk)]
[(vector f (list-rest cm-key cm-val))
(with-continuation-mark cm-key cm-val (rebuild-cms fs thunk))])]))
[(vector #f (list))
(rebuild-cms fs thunk)]
[(vector #f (list-rest (list-rest cm-key cm-val) cms))
(with-continuation-mark cm-key cm-val
(begin
#;(printf "rcm: w-c-m ~S ~S~n" cm-key cm-val)
(rebuild-cms (list* (vector #f cms) fs) thunk)))])]))
(define (abort/cc thunk)
(call-with-continuation-prompt

52
collects/web-server/prototype-web-server/tests/param-tests.ss Normal file
View File

@ -0,0 +1,52 @@
(module param-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"util.ss")
(provide param-suite)
(define the-dispatch
`(lambda (k*v)
(lambda (k*v)
((car k*v) k*v))))
(define param-suite
(test-suite
"Test Web Parameters"
;; ****************************************
;; ****************************************
;; BASIC TESTS
(test-suite
"Basic Tests"
(test-case
"web-parameterize does not overwrite with multiple parameters"
(let-values ([(go meval)
(make-module-eval
(module m (lib "lang.ss" "web-server" "prototype-web-server")
(define first (make-web-parameter #f))
(define second (make-web-parameter #f))
(provide start)
(define (start initial)
(web-parameterize ([first 1]
[second 2])
(+ (first) (second))))))])
(go the-dispatch)
(check = 3 (meval '(dispatch-start #f)))))
(test-case
"web-parameterize does not overwrite with multiple parameters across send/suspend"
(let-values ([(go meval)
(make-module-eval
(module m (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define first (make-web-parameter #f))
(define second (make-web-parameter #f))
(define (start ignore)
(web-parameterize ([first 1]
[second 2])
(send/suspend (lambda (k) k))
(+ (first) (second))))))])
(go the-dispatch)
(let ([first-key (meval '(dispatch-start #f))])
(check = 3 (meval `(dispatch (list ,first-key #f)))))))))))

17
collects/web-server/prototype-web-server/tests/suite.ss
View File

@ -8,15 +8,18 @@
"labels-tests.ss"
"lang-tests.ss"
"certify-tests.ss"
"stuff-url-tests.ss")
"stuff-url-tests.ss"
"param-tests.ss")
(test/graphical-ui
(test-suite
"Main Tests for Prototype Web Server"
#;persistent-close-suite
persistent-close-suite
stuff-url-suite
#;anormal-tests
#;closure-tests-suite
#;labels-tests-suite
#;lang-suite
#;certify-suite)))
anormal-tests
closure-tests-suite
labels-tests-suite
lang-suite
certify-suite
param-suite
)))