124 lines
4.9 KiB
Scheme
124 lines
4.9 KiB
Scheme
(module dispatch-lang mzscheme
|
|
(require (lib "kw.ss")
|
|
(lib "list.ss")
|
|
(lib "contract.ss")
|
|
(lib "url.ss" "net")
|
|
(lib "session.ss" "web-server" "private")
|
|
(only "../lang/web.ss"
|
|
initialize-servlet)
|
|
(lib "web-cells.ss" "web-server" "lang")
|
|
"../private/request-structs.ss"
|
|
"dispatch.ss"
|
|
"../private/connection-manager.ss"
|
|
"../private/util.ss"
|
|
"../private/response.ss"
|
|
"../configuration/namespace.ss"
|
|
"../configuration/responders.ss")
|
|
|
|
(provide/contract
|
|
[interface-version dispatcher-interface-version?])
|
|
(provide make)
|
|
|
|
(define top-cust (current-custodian))
|
|
|
|
; same-servlet? : url? url? -> boolean?
|
|
(define (same-servlet? req ses)
|
|
(define (abstract-url u)
|
|
(map path/param-path
|
|
(url-path u)))
|
|
#;(printf "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans)
|
|
(list-prefix? (abstract-url ses) (abstract-url req)))
|
|
|
|
;; 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))
|
|
|
|
;; XXX url->servlet, get rid of timeout, optional session manager
|
|
(define interface-version 'v1)
|
|
(define/kw (make #:key
|
|
url->path
|
|
[make-servlet-namespace
|
|
(make-make-servlet-namespace)]
|
|
[timeouts-servlet-connection (* 60 60 24)]
|
|
[responders-servlet-loading
|
|
servlet-loading-responder]
|
|
[responders-servlet
|
|
(gen-servlet-responder "servlet-error.html")])
|
|
|
|
;; dispatch : connection request -> void
|
|
(define (dispatch conn req)
|
|
(define uri (request-uri req))
|
|
(adjust-connection-timeout! conn timeouts-servlet-connection)
|
|
;; XXX - make timeouts proportional to size of bindings
|
|
(cond
|
|
[(extract-session uri)
|
|
=> (lambda (session-id)
|
|
(resume-session session-id conn req))]
|
|
[else
|
|
(begin-session conn req)]))
|
|
|
|
;; XXX Currently there are just sessions, should be servlets and sessions
|
|
;; XXX Control extent of servlet data
|
|
;; begin-session: connection request
|
|
(define (begin-session conn req)
|
|
(define uri (request-uri req))
|
|
(with-handlers ([void (lambda (exn) (next-dispatcher))])
|
|
(define-values (a-path url-servlet-path) (url->path uri))
|
|
(with-handlers ([void
|
|
(lambda (the-exn)
|
|
(output-response/method
|
|
conn
|
|
(responders-servlet-loading uri the-exn)
|
|
(request-method req)))])
|
|
(parameterize ([current-directory (directory-part a-path)])
|
|
(define cust (make-custodian top-cust))
|
|
(define ns (make-servlet-namespace
|
|
#:additional-specs
|
|
'((lib "web-cells.ss" "web-server" "lang")
|
|
(lib "abort-resume.ss" "web-server" "lang")
|
|
(lib "session.ss" "web-server" "private")
|
|
(lib "request-structs.ss" "web-server" "private"))))
|
|
(define ses (new-session cust ns (make-session-url uri (map path->string url-servlet-path))))
|
|
(parameterize ([current-custodian cust]
|
|
[current-namespace ns]
|
|
[current-session ses])
|
|
(define start
|
|
(dynamic-require `(file ,(path->string a-path))
|
|
'start))
|
|
(set-session-servlet! ses (initialize-servlet start)))
|
|
(resume-session (session-id ses)
|
|
conn req)))))
|
|
|
|
;; resume-session: number connection request
|
|
(define (resume-session ses-id conn req)
|
|
(cond
|
|
[(lookup-session ses-id)
|
|
=> (lambda (ses)
|
|
(if (same-servlet? (request-uri req) (session-url ses))
|
|
(parameterize ([current-custodian (session-cust ses)]
|
|
[current-session ses])
|
|
(with-handlers ([void
|
|
(lambda (the-exn)
|
|
(output-response/method
|
|
conn
|
|
(responders-servlet (request-uri req) the-exn)
|
|
(request-method req)))])
|
|
(output-response conn ((session-servlet ses) req))))
|
|
(begin-session conn req)))]
|
|
[else
|
|
(begin-session conn req)]))
|
|
|
|
dispatch)) |