diff --git a/collects/tests/web-server/private/all-private-tests.ss b/collects/tests/web-server/private/all-private-tests.ss index 62357dcf24..d9ceefd816 100644 --- a/collects/tests/web-server/private/all-private-tests.ss +++ b/collects/tests/web-server/private/all-private-tests.ss @@ -5,7 +5,6 @@ "response-test.ss" "connection-manager-test.ss" "define-closure-test.ss" - "session-test.ss" "mime-types-test.ss" "url-param-test.ss" "mod-map-test.ss" @@ -21,7 +20,6 @@ mime-types-tests mod-map-tests request-tests - response-tests - session-tests + response-tests url-param-tests util-tests)) diff --git a/collects/tests/web-server/private/session-test.ss b/collects/tests/web-server/private/session-test.ss index 0606e0dd5f..b2597ef20a 100644 --- a/collects/tests/web-server/private/session-test.ss +++ b/collects/tests/web-server/private/session-test.ss @@ -14,17 +14,17 @@ (test-case "new-session" - (check-true (session? (new-session (make-custodian) (make-base-empty-namespace) url0 url0ps)))) + (check-true (session? (new-session (make-custodian) (make-base-empty-namespace) url0)))) (test-case "lookup-session" - (let ([ses (new-session (make-custodian) (make-base-empty-namespace) url0 url0ps)]) + (let ([ses (new-session (make-custodian) (make-base-empty-namespace) url0)]) (install-session ses url0ps) (check-eq? (lookup-session url0ps) ses))) (test-case "lookup-session (fail)" - (let ([ses (new-session (make-custodian) (make-base-empty-namespace) url0 url0ps)]) + (let ([ses (new-session (make-custodian) (make-base-empty-namespace) url0)]) (install-session ses url0ps) (check-false (lookup-session empty)))))) diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index 1de4927a5f..595a12eff6 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -1,10 +1,11 @@ #lang scheme/base (require mzlib/list scheme/contract - web-server/private/session (only-in "../lang/web.ss" initialize-servlet) web-server/lang/web-cells + web-server/managers/none + web-server/private/servlet "../private/request-structs.ss" "../private/response-structs.ss" "dispatch.ss" @@ -25,6 +26,19 @@ #:responders-servlet (url? any/c . -> . response?)) dispatcher/c)]) +;; HACK +(define the-session-table (make-weak-hash)) + +(define (install-session ses paths) + (hash-set! the-session-table paths ses)) + +;; lookup-session : (listof string) -> (union session #f) +(define (lookup-session paths) + (hash-ref the-session-table paths + (lambda () #f))) +;; /HACK + + (define interface-version 'v1) (define (make #:url->path url->path #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] @@ -52,27 +66,36 @@ (define ns (make-servlet-namespace #:additional-specs '(web-server/lang/web-cells - web-server/lang/abort-resume - web-server/private/session + web-server/lang/abort-resume + web-server/private/servlet web-server/private/request-structs))) - (define ses (new-session cust ns uri url-servlet-paths)) + (define dir (directory-part a-path)) + (define ses + (make-servlet + cust ns + (create-none-manager (lambda (req) (error "No continuations!"))) + dir + (lambda (req) (error "session not initialized")))) (parameterize ([current-custodian cust] - [current-directory (directory-part a-path)] + [current-directory dir] [current-namespace ns] - [current-session ses]) + [current-execution-context (make-execution-context req)] + [current-servlet ses]) (define start (dynamic-require `(file ,(path->string a-path)) 'start)) - (set-session-servlet! ses (initialize-servlet start))) + (set-servlet-handler! ses (initialize-servlet start))) (install-session ses url-servlet-paths) ses)])) - (parameterize ([current-custodian (session-cust ses)] - [current-namespace (session-namespace ses)] - [current-session ses]) + (parameterize ([current-custodian (servlet-custodian ses)] + [current-directory (servlet-directory ses)] + [current-namespace (servlet-namespace ses)] + [current-execution-context (make-execution-context req)] + [current-servlet ses]) (with-handlers ([exn? (lambda (the-exn) (output-response/method conn (responders-servlet uri the-exn) (request-method req)))]) - (output-response conn ((session-servlet ses) req)))))))) \ No newline at end of file + (output-response conn ((servlet-handler ses) req)))))))) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index d96ae17a11..ce5e3cf100 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -149,6 +149,7 @@ (define uri (request-uri req)) (define instance-custodian (make-servlet-custodian)) (parameterize ([current-custodian instance-custodian] + [current-execution-context (make-execution-context req)] [exit-handler (lambda _ (kill-connection! conn) @@ -173,28 +174,27 @@ [current-directory (servlet-directory the-servlet)] [current-namespace (servlet-namespace the-servlet)]) (define manager (servlet-manager the-servlet)) - (parameterize ([current-execution-context (make-execution-context req)]) - - (define-values (instance-id handler) - (cond - [(continuation-url? uri) - => (match-lambda - [(list instance-id k-id salt) - (values instance-id - (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] - [else - (values ((manager-create-instance manager) (exit-handler)) - (servlet-handler the-servlet))])) - - (parameterize ([current-servlet-instance-id instance-id]) - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (responders-servlet - (request-uri req) - exn))]) - (call-with-continuation-prompt - (lambda () - (handler req)) - servlet-prompt))))))) + + (define-values (instance-id handler) + (cond + [(continuation-url? uri) + => (match-lambda + [(list instance-id k-id salt) + (values instance-id + (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] + [else + (values ((manager-create-instance manager) (exit-handler)) + (servlet-handler the-servlet))])) + + (parameterize ([current-servlet-instance-id instance-id]) + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (responders-servlet + (request-uri req) + exn))]) + (call-with-continuation-prompt + (lambda () + (handler req)) + servlet-prompt)))))) (output-response conn response)))) \ No newline at end of file diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index 5331cc44e0..5eadcc3f69 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -5,10 +5,9 @@ web-server/private/request-structs web-server/private/response-structs web-server/private/define-closure + web-server/private/servlet "../private/request-structs.ss" "abort-resume.ss" - (only-in "../private/session.ss" - session-url current-session) "stuff-url.ss" "../private/url-param.ss") @@ -54,7 +53,7 @@ (lambda (k) (let ([p-cont (serialize k)]) (page-maker - (session-url (current-session)) + (request-uri (execution-context-request (current-execution-context))) `(input ([type "hidden"] [name "kont"] [value ,(format "~s" p-cont)]))))))) ;; send/suspend/url: (url -> response) -> request @@ -64,11 +63,11 @@ (lambda (k) (page-maker (stuff-url k - (session-url (current-session))))))) + (request-uri (execution-context-request (current-execution-context)))))))) (define-closure embed/url (proc) (k) (stuff-url (kont-append-fun k proc) - (session-url (current-session)))) + (request-uri (execution-context-request (current-execution-context))))) (define (send/suspend/dispatch response-generator) (send/suspend (lambda (k) diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index daac93335b..c7faf977d5 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -32,7 +32,7 @@ [handler (request? . -> . response?)])] [struct execution-context ([request request?])] - [current-servlet (parameter/c servlet?)] - [current-servlet-instance-id (parameter/c number?)] - [current-execution-context (parameter/c execution-context?)] + [current-servlet (parameter/c (or/c false/c servlet?))] + [current-servlet-instance-id (parameter/c (or/c false/c number?))] + [current-execution-context (parameter/c (or/c false/c execution-context?))] [current-servlet-manager (-> manager?)]) diff --git a/collects/web-server/private/session.ss b/collects/web-server/private/session.ss deleted file mode 100644 index db2465403d..0000000000 --- a/collects/web-server/private/session.ss +++ /dev/null @@ -1,58 +0,0 @@ -#lang scheme/base -(require scheme/contract - mzlib/list - net/url - "response-structs.ss" - "request-structs.ss") - -;; make-session-url: url (listof string) -> url -;; produce a new url for this session: -;; Minimal path to the servlet. -;; No query. -;; No fragment. -(define (make-session-url uri new-path) - (make-url - (url-scheme uri) - (url-user uri) - (url-host uri) - (url-port uri) - #t - (map (lambda (p) (make-path/param p empty)) - new-path) - empty - #f)) - -(define-struct session (cust namespace servlet url) - #:mutable) - -(provide/contract - [struct session ([cust custodian?] - [namespace namespace?] - [servlet (request? . -> . response?)] - [url url?])] - [lookup-session ((listof string?) . -> . (or/c session? false/c))] - [install-session (session? (listof string?) . -> . void)] - [new-session (custodian? namespace? url? (listof string?) . -> . session?)] - [current-session (parameter/c session?)]) - -(define current-session (make-parameter #f)) - -(define the-session-table (make-weak-hash)) - -;; new-session : namespace path uri (listof string) -> session -(define (new-session cust ns uri paths) - (define ses (make-session - cust - ns - (lambda (req) (error "session not initialized")) - (make-session-url uri paths))) - #;(printf "New session of ~a~n" (hash-table-count the-session-table)) - ses) - -(define (install-session ses paths) - (hash-set! the-session-table paths ses)) - -;; lookup-session : (listof string) -> (union session #f) -(define (lookup-session paths) - (hash-ref the-session-table paths - (lambda () #f)))