diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index 8aa65a64d6..176424ed0e 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss @@ -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 diff --git a/collects/web-server/prototype-web-server/lang/elim-callcc.ss b/collects/web-server/prototype-web-server/lang/elim-callcc.ss index 3f1a331eb8..5ae77ad5de 100644 --- a/collects/web-server/prototype-web-server/lang/elim-callcc.ss +++ b/collects/web-server/prototype-web-server/lang/elim-callcc.ss @@ -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] diff --git a/collects/web-server/prototype-web-server/private/abort-resume.ss b/collects/web-server/prototype-web-server/private/abort-resume.ss index 252ea5ada6..a213fb941d 100644 --- a/collects/web-server/prototype-web-server/private/abort-resume.ss +++ b/collects/web-server/prototype-web-server/private/abort-resume.ss @@ -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 diff --git a/collects/web-server/prototype-web-server/tests/param-tests.ss b/collects/web-server/prototype-web-server/tests/param-tests.ss new file mode 100644 index 0000000000..dbae320126 --- /dev/null +++ b/collects/web-server/prototype-web-server/tests/param-tests.ss @@ -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))))))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/suite.ss b/collects/web-server/prototype-web-server/tests/suite.ss index c80f55fb56..7c93c724e7 100644 --- a/collects/web-server/prototype-web-server/tests/suite.ss +++ b/collects/web-server/prototype-web-server/tests/suite.ss @@ -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))) \ No newline at end of file + anormal-tests + closure-tests-suite + labels-tests-suite + lang-suite + certify-suite + param-suite + ))) \ No newline at end of file