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

Slowly merging the two servlet regimes

Browse Source 
svn: r12377
This commit is contained in:
Jay McCarthy 2008-11-10 18:45:44 +00:00
parent 138a64c24b
commit f7481b0c08
7 changed files with 68 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/web-server/private/all-private-tests.ss
View File

@ -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"
@ -22,6 +21,5 @@
mod-map-tests
request-tests
response-tests
session-tests
url-param-tests
util-tests))

6
collects/tests/web-server/private/session-test.ss
View File

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

43
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -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)]
@ -53,26 +67,35 @@
#:additional-specs
'(web-server/lang/web-cells
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)]
[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))))))))
(output-response conn ((servlet-handler ses) req))))))))

4
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -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,7 +174,6 @@
[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
@ -195,6 +195,6 @@
(call-with-continuation-prompt
(lambda ()
(handler req))
servlet-prompt)))))))
servlet-prompt))))))
(output-response conn response))))

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

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

6
collects/web-server/private/servlet.ss
View File

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

58
collects/web-server/private/session.ss
View File

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