Slowly merging the two servlet regimes

svn: r12377

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
+   response-tests   
-   session-tests
    url-param-tests
    util-tests))

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

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/lang/abort-resume                             
-                             web-server/private/session
+                             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)]
+        (parameterize ([current-custodian (servlet-custodian ses)]
-                       [current-namespace (session-namespace ses)]
+                       [current-directory (servlet-directory ses)]
-                       [current-session 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))))))))
+            (output-response conn ((servlet-handler ses) req))))))))

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)
-              (define-values (instance-id handler)
+              (cond
-                (cond
+                [(continuation-url? uri)
-                  [(continuation-url? uri)
+                 => (match-lambda
-                   => (match-lambda
+                      [(list instance-id k-id salt)
-                        [(list instance-id k-id salt)
+                       (values instance-id
-                         (values instance-id
+                               (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
-                                 (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
+                [else
-                  [else
+                 (values ((manager-create-instance manager) (exit-handler))
-                   (values ((manager-create-instance manager) (exit-handler))
+                         (servlet-handler the-servlet))]))
-                           (servlet-handler the-servlet))]))
+            
-              
+            (parameterize ([current-servlet-instance-id instance-id])
-              (parameterize ([current-servlet-instance-id instance-id])
+              (with-handlers ([(lambda (x) #t)
-                (with-handlers ([(lambda (x) #t)
+                               (lambda (exn)
-                                 (lambda (exn)
+                                 (responders-servlet
-                                   (responders-servlet
+                                  (request-uri req)
-                                    (request-uri req)
+                                  exn))])
-                                    exn))])
+                (call-with-continuation-prompt
-                  (call-with-continuation-prompt
+                 (lambda ()
-                   (lambda ()
+                   (handler req))
-                     (handler req))
+                 servlet-prompt))))))
-                   servlet-prompt)))))))
       
       (output-response conn response))))

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)

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 (parameter/c (or/c false/c servlet?))]
- [current-servlet-instance-id (parameter/c number?)]
+ [current-servlet-instance-id (parameter/c (or/c false/c number?))]
- [current-execution-context (parameter/c execution-context?)]
+ [current-execution-context (parameter/c (or/c false/c execution-context?))]
  [current-servlet-manager (-> manager?)])

collects/web-server/private/session.ss

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