conforming to dispatcher pattern
svn: r6304
This commit is contained in:
Jay McCarthy
parent
878b988b48
commit
3f7fdcac43
|
|
@ -17,12 +17,15 @@
|
||||||
(define host-info hardcoded-host)
|
(define host-info hardcoded-host)
|
||||||
(define dispatch
|
(define dispatch
|
||||||
(sequencer:make
|
(sequencer:make
|
||||||
(lambda (conn req)
|
(prototype:make #:servlet-root (paths-servlet (host-paths host-info))
|
||||||
(prototype:dispatch conn req host-info))
|
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
|
||||||
|
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
|
||||||
|
#:responders-servlet (responders-servlet (host-responders host-info))
|
||||||
|
#:responders-file-not-found (responders-file-not-found (host-responders host-info)))
|
||||||
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
|
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
|
||||||
#:mime-types-path (paths-mime-types (host-paths host-info))
|
#:mime-types-path (paths-mime-types (host-paths host-info))
|
||||||
#:indices (host-indices host-info)
|
#:indices (host-indices host-info)
|
||||||
#:file-not-found-responder (responders-file-not-found (host-responders host-info)))))
|
#:file-not-found-responder (responders-file-not-found (host-responders host-info)))))
|
||||||
|
|
||||||
(define-values/invoke-unit
|
(define-values/invoke-unit
|
||||||
dispatch-server@
|
dispatch-server@
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,7 @@
|
||||||
(module server mzscheme
|
(module server mzscheme
|
||||||
(require (lib "connection-manager.ss" "web-server" "private")
|
(require (lib "kw.ss")
|
||||||
|
"../private/configuration.ss"
|
||||||
|
(lib "connection-manager.ss" "web-server" "private")
|
||||||
(lib "response.ss" "web-server")
|
(lib "response.ss" "web-server")
|
||||||
(lib "servlet-helpers.ss" "web-server" "private")
|
(lib "servlet-helpers.ss" "web-server" "private")
|
||||||
(lib "response.ss" "web-server" "private")
|
(lib "response.ss" "web-server" "private")
|
||||||
|
|
@ -7,7 +9,6 @@
|
||||||
(lib "url.ss" "net")
|
(lib "url.ss" "net")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "plt-match.ss")
|
(lib "plt-match.ss")
|
||||||
(lib "configuration-structures.ss" "web-server" "private")
|
|
||||||
(lib "dispatch.ss" "web-server" "dispatchers")
|
(lib "dispatch.ss" "web-server" "dispatchers")
|
||||||
(lib "session.ss" "web-server" "prototype-web-server")
|
(lib "session.ss" "web-server" "prototype-web-server")
|
||||||
(only (lib "abort-resume.ss" "web-server" "prototype-web-server")
|
(only (lib "abort-resume.ss" "web-server" "prototype-web-server")
|
||||||
|
|
@ -18,7 +19,7 @@
|
||||||
"xexpr-extras.ss"
|
"xexpr-extras.ss"
|
||||||
"utils.ss")
|
"utils.ss")
|
||||||
|
|
||||||
(provide dispatch)
|
(provide make)
|
||||||
|
|
||||||
(define myprint printf #;(lambda _ (void)))
|
(define myprint printf #;(lambda _ (void)))
|
||||||
|
|
||||||
|
|
@ -26,174 +27,181 @@
|
||||||
(define-struct connection-state (conn req))
|
(define-struct connection-state (conn req))
|
||||||
(define top-cust (current-custodian))
|
(define top-cust (current-custodian))
|
||||||
|
|
||||||
;; ************************************************************
|
(define/kw (make #:key
|
||||||
;; dispatch: connection request host -> void
|
[servlet-root "servlets"]
|
||||||
;; trivial dispatcher
|
[timeouts-servlet-connection (* 60 60 24)]
|
||||||
(define (dispatch conn req host-info)
|
[responders-servlet-loading
|
||||||
(define-values (uri method path) (decompose-request req))
|
servlet-loading-responder]
|
||||||
(myprint "dispatch~n")
|
[responders-servlet
|
||||||
(if (regexp-match #rx"^/servlets" path)
|
(gen-servlet-responder "servlet-error.html")]
|
||||||
(begin
|
[responders-file-not-found
|
||||||
(adjust-connection-timeout!
|
(gen-file-not-found-responder "not-found.html")])
|
||||||
conn
|
|
||||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
|
||||||
;; more here - make timeouts proportional to size of bindings
|
|
||||||
(servlet-content-producer conn req host-info))
|
|
||||||
(next-dispatcher)))
|
|
||||||
|
|
||||||
;; ************************************************************
|
;; ************************************************************
|
||||||
;; ************************************************************
|
;; dispatch: connection request host -> void
|
||||||
;; SERVING SERVLETS
|
;; trivial dispatcher
|
||||||
|
(define (dispatch conn req)
|
||||||
|
(define-values (uri method path) (decompose-request req))
|
||||||
|
(myprint "dispatch~n")
|
||||||
|
(if (regexp-match #rx"^/servlets" path)
|
||||||
|
(begin
|
||||||
|
(adjust-connection-timeout! conn timeouts-servlet-connection)
|
||||||
|
;; more here - make timeouts proportional to size of bindings
|
||||||
|
(servlet-content-producer conn req))
|
||||||
|
(next-dispatcher)))
|
||||||
|
|
||||||
;; servlet-content-producer: connection request host -> void
|
;; ************************************************************
|
||||||
(define (servlet-content-producer conn req host-info)
|
;; ************************************************************
|
||||||
(myprint "servlet-content-producer~n")
|
;; SERVING SERVLETS
|
||||||
(let ([meth (request-method req)])
|
|
||||||
(if (eq? meth 'head)
|
|
||||||
(output-response/method
|
|
||||||
conn
|
|
||||||
(make-response/full
|
|
||||||
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
|
|
||||||
'() (list "ignored"))
|
|
||||||
meth)
|
|
||||||
(let ([uri (request-uri req)])
|
|
||||||
(thread-cell-set! thread-connection-state
|
|
||||||
(make-connection-state conn req))
|
|
||||||
(with-handlers ([void
|
|
||||||
(lambda (the-exn)
|
|
||||||
(output-response/method
|
|
||||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
|
||||||
((responders-servlet-loading (host-responders host-info))
|
|
||||||
uri the-exn)
|
|
||||||
(request-method
|
|
||||||
(connection-state-req
|
|
||||||
(thread-cell-ref thread-connection-state)))))])
|
|
||||||
(cond
|
|
||||||
[(resume-session? uri)
|
|
||||||
=> (lambda (session-id)
|
|
||||||
(resume-session session-id host-info))]
|
|
||||||
[else
|
|
||||||
(begin-session host-info)]))))))
|
|
||||||
|
|
||||||
;; Parameter Parsing
|
;; servlet-content-producer: connection request host -> void
|
||||||
|
(define (servlet-content-producer conn req)
|
||||||
;; encodes a simple number:
|
(myprint "servlet-content-producer~n")
|
||||||
(define URL-PARAMS:REGEXP (regexp "([0-9]+)"))
|
(let ([meth (request-method req)])
|
||||||
|
(if (eq? meth 'head)
|
||||||
(define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
|
|
||||||
|
|
||||||
;; resume-session? url -> (union number #f)
|
|
||||||
;; Determine if the url encodes a session-id and extract it
|
|
||||||
(define (resume-session? a-url)
|
|
||||||
(myprint "resume-session?: url-string = ~s~n" (url->string a-url))
|
|
||||||
(let ([k-params (filter match-url-params
|
|
||||||
(apply append
|
|
||||||
(map path/param-param (url-path a-url))))])
|
|
||||||
(myprint "resume-session?: ~S~n" k-params)
|
|
||||||
(if (empty? k-params)
|
|
||||||
#f
|
|
||||||
(match (match-url-params (first k-params))
|
|
||||||
[(list _ n)
|
|
||||||
(myprint "resume-session?: Found ~a~n" n)
|
|
||||||
(string->number n)]
|
|
||||||
[_
|
|
||||||
#f]))))
|
|
||||||
|
|
||||||
;; url->param: url -> (union string #f)
|
|
||||||
(define (url->param a-url)
|
|
||||||
(let ([l (filter path/param? (url-path a-url))])
|
|
||||||
(and (not (null? l))
|
|
||||||
(path/param-param (car l)))))
|
|
||||||
|
|
||||||
;(resume-session? (string->url "http://localhost:9000/;123"))
|
|
||||||
;(resume-session? (string->url "http://localhost:9000/;foo"))
|
|
||||||
;(resume-session? (string->url "http://localhost:9000/foo/bar"))
|
|
||||||
|
|
||||||
;; ************************************************************
|
|
||||||
|
|
||||||
;; begin-session: connection request host-info
|
|
||||||
(define (begin-session host-info)
|
|
||||||
(myprint "begin-session~n")
|
|
||||||
(let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))])
|
|
||||||
(let-values ([(a-path url-servlet-path url-path-suffix)
|
|
||||||
(url->servlet-path
|
|
||||||
(paths-servlet (host-paths host-info))
|
|
||||||
uri)])
|
|
||||||
(myprint "a-path = ~s~n" a-path)
|
|
||||||
(if a-path
|
|
||||||
(parameterize ([current-directory (directory-part a-path)])
|
|
||||||
(let* ([cust (make-custodian top-cust)]
|
|
||||||
[ns (make-servlet-namespace)]
|
|
||||||
[ses (new-session cust ns (make-session-url uri url-servlet-path) a-path)])
|
|
||||||
(parameterize ([current-custodian cust]
|
|
||||||
[current-namespace ns]
|
|
||||||
[current-session ses])
|
|
||||||
(let* ([module-name `(file ,(path->string a-path))])
|
|
||||||
(myprint "dynamic-require ...~n")
|
|
||||||
(with-handlers ([exn:fail:contract?
|
|
||||||
(lambda _
|
|
||||||
(dynamic-require module-name #f))])
|
|
||||||
(let ([start (dynamic-require module-name 'start)])
|
|
||||||
(run-start start-servlet start)))))
|
|
||||||
(myprint "resume-session~n")
|
|
||||||
(resume-session (session-id ses) host-info)))
|
|
||||||
(output-response/method
|
(output-response/method
|
||||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
conn
|
||||||
((responders-file-not-found (host-responders host-info)) uri)
|
(make-response/full
|
||||||
(request-method (connection-state-req (thread-cell-ref thread-connection-state))))))))
|
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
|
||||||
|
'() (list "ignored"))
|
||||||
(define to-be-copied-module-specs
|
meth)
|
||||||
'(mzscheme
|
(let ([uri (request-uri req)])
|
||||||
(lib "web-cells.ss" "web-server" "prototype-web-server" "newcont")
|
(thread-cell-set! thread-connection-state
|
||||||
(lib "abort-resume.ss" "web-server" "prototype-web-server")
|
(make-connection-state conn req))
|
||||||
(lib "session.ss" "web-server" "prototype-web-server")
|
|
||||||
(lib "request.ss" "web-server" "private")))
|
|
||||||
|
|
||||||
;; get the names of those modules.
|
|
||||||
(define to-be-copied-module-names
|
|
||||||
(let ([get-name
|
|
||||||
(lambda (spec)
|
|
||||||
(if (symbol? spec)
|
|
||||||
spec
|
|
||||||
((current-module-name-resolver) spec #f #f)))])
|
|
||||||
(map get-name to-be-copied-module-specs)))
|
|
||||||
|
|
||||||
(define (make-servlet-namespace)
|
|
||||||
(let ([server-namespace (current-namespace)]
|
|
||||||
[new-namespace (make-namespace)])
|
|
||||||
(parameterize ([current-namespace new-namespace])
|
|
||||||
(for-each (lambda (name) (namespace-attach-module server-namespace name))
|
|
||||||
to-be-copied-module-names)
|
|
||||||
new-namespace)))
|
|
||||||
|
|
||||||
;; ************************************************************
|
|
||||||
;; resume-session: connection request number host-info
|
|
||||||
(define (resume-session ses-id host-info)
|
|
||||||
; XXX Check if session is for same servlet!
|
|
||||||
(myprint "resume-session: ses-id = ~s~n" ses-id)
|
|
||||||
(cond
|
|
||||||
[(lookup-session ses-id)
|
|
||||||
=> (lambda (ses)
|
|
||||||
(parameterize ([current-custodian (session-cust ses)]
|
|
||||||
[current-session ses])
|
|
||||||
(with-handlers ([void
|
(with-handlers ([void
|
||||||
(lambda (the-exn)
|
(lambda (the-exn)
|
||||||
(output-response/method
|
(output-response/method
|
||||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||||
((responders-servlet (host-responders host-info))
|
(responders-servlet-loading uri the-exn)
|
||||||
(request-uri
|
|
||||||
(connection-state-req
|
|
||||||
(thread-cell-ref thread-connection-state)))
|
|
||||||
the-exn)
|
|
||||||
(request-method
|
(request-method
|
||||||
(connection-state-req (thread-cell-ref thread-connection-state)))))])
|
(connection-state-req
|
||||||
(printf "session-handler ~S~n" (session-handler ses))
|
(thread-cell-ref thread-connection-state)))))])
|
||||||
(output-response
|
(cond
|
||||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
[(resume-session? uri)
|
||||||
(xexpr+extras->xexpr
|
=> (lambda (session-id)
|
||||||
((session-handler ses)
|
(resume-session session-id))]
|
||||||
(connection-state-req (thread-cell-ref thread-connection-state))))))))]
|
[else
|
||||||
[else
|
(begin-session)]))))))
|
||||||
(myprint "resume-session: Unknown ses~n")
|
|
||||||
;; TODO: should just start a new session here.
|
;; Parameter Parsing
|
||||||
(begin-session host-info)])))
|
|
||||||
|
;; encodes a simple number:
|
||||||
|
(define URL-PARAMS:REGEXP (regexp "([0-9]+)"))
|
||||||
|
|
||||||
|
(define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
|
||||||
|
|
||||||
|
;; resume-session? url -> (union number #f)
|
||||||
|
;; Determine if the url encodes a session-id and extract it
|
||||||
|
(define (resume-session? a-url)
|
||||||
|
(myprint "resume-session?: url-string = ~s~n" (url->string a-url))
|
||||||
|
(let ([k-params (filter match-url-params
|
||||||
|
(apply append
|
||||||
|
(map path/param-param (url-path a-url))))])
|
||||||
|
(myprint "resume-session?: ~S~n" k-params)
|
||||||
|
(if (empty? k-params)
|
||||||
|
#f
|
||||||
|
(match (match-url-params (first k-params))
|
||||||
|
[(list _ n)
|
||||||
|
(myprint "resume-session?: Found ~a~n" n)
|
||||||
|
(string->number n)]
|
||||||
|
[_
|
||||||
|
#f]))))
|
||||||
|
|
||||||
|
;; url->param: url -> (union string #f)
|
||||||
|
(define (url->param a-url)
|
||||||
|
(let ([l (filter path/param? (url-path a-url))])
|
||||||
|
(and (not (null? l))
|
||||||
|
(path/param-param (car l)))))
|
||||||
|
|
||||||
|
;(resume-session? (string->url "http://localhost:9000/;123"))
|
||||||
|
;(resume-session? (string->url "http://localhost:9000/;foo"))
|
||||||
|
;(resume-session? (string->url "http://localhost:9000/foo/bar"))
|
||||||
|
|
||||||
|
;; ************************************************************
|
||||||
|
|
||||||
|
;; begin-session: connection request host-info
|
||||||
|
(define (begin-session)
|
||||||
|
(myprint "begin-session~n")
|
||||||
|
(let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))])
|
||||||
|
(let-values ([(a-path url-servlet-path url-path-suffix)
|
||||||
|
(url->servlet-path servlet-root uri)])
|
||||||
|
(myprint "a-path = ~s~n" a-path)
|
||||||
|
(if a-path
|
||||||
|
(parameterize ([current-directory (directory-part a-path)])
|
||||||
|
(let* ([cust (make-custodian top-cust)]
|
||||||
|
[ns (make-servlet-namespace)]
|
||||||
|
[ses (new-session cust ns (make-session-url uri url-servlet-path) a-path)])
|
||||||
|
(parameterize ([current-custodian cust]
|
||||||
|
[current-namespace ns]
|
||||||
|
[current-session ses])
|
||||||
|
(let* ([module-name `(file ,(path->string a-path))])
|
||||||
|
(myprint "dynamic-require ...~n")
|
||||||
|
(with-handlers ([exn:fail:contract?
|
||||||
|
(lambda _
|
||||||
|
(dynamic-require module-name #f))])
|
||||||
|
(let ([start (dynamic-require module-name 'start)])
|
||||||
|
(run-start start-servlet start)))))
|
||||||
|
(myprint "resume-session~n")
|
||||||
|
(resume-session (session-id ses))))
|
||||||
|
(output-response/method
|
||||||
|
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||||
|
(responders-file-not-found uri)
|
||||||
|
(request-method (connection-state-req (thread-cell-ref thread-connection-state))))))))
|
||||||
|
|
||||||
|
(define to-be-copied-module-specs
|
||||||
|
'(mzscheme
|
||||||
|
(lib "web-cells.ss" "web-server" "prototype-web-server" "newcont")
|
||||||
|
(lib "abort-resume.ss" "web-server" "prototype-web-server")
|
||||||
|
(lib "session.ss" "web-server" "prototype-web-server")
|
||||||
|
(lib "request.ss" "web-server" "private")))
|
||||||
|
|
||||||
|
;; get the names of those modules.
|
||||||
|
(define to-be-copied-module-names
|
||||||
|
(let ([get-name
|
||||||
|
(lambda (spec)
|
||||||
|
(if (symbol? spec)
|
||||||
|
spec
|
||||||
|
((current-module-name-resolver) spec #f #f)))])
|
||||||
|
(map get-name to-be-copied-module-specs)))
|
||||||
|
|
||||||
|
(define (make-servlet-namespace)
|
||||||
|
(let ([server-namespace (current-namespace)]
|
||||||
|
[new-namespace (make-namespace)])
|
||||||
|
(parameterize ([current-namespace new-namespace])
|
||||||
|
(for-each (lambda (name) (namespace-attach-module server-namespace name))
|
||||||
|
to-be-copied-module-names)
|
||||||
|
new-namespace)))
|
||||||
|
|
||||||
|
;; ************************************************************
|
||||||
|
;; resume-session: connection request number host-info
|
||||||
|
(define (resume-session ses-id)
|
||||||
|
; XXX Check if session is for same servlet!
|
||||||
|
(myprint "resume-session: ses-id = ~s~n" ses-id)
|
||||||
|
(cond
|
||||||
|
[(lookup-session ses-id)
|
||||||
|
=> (lambda (ses)
|
||||||
|
(parameterize ([current-custodian (session-cust ses)]
|
||||||
|
[current-session ses])
|
||||||
|
(with-handlers ([void
|
||||||
|
(lambda (the-exn)
|
||||||
|
(output-response/method
|
||||||
|
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||||
|
(responders-servlet
|
||||||
|
(request-uri
|
||||||
|
(connection-state-req
|
||||||
|
(thread-cell-ref thread-connection-state)))
|
||||||
|
the-exn)
|
||||||
|
(request-method
|
||||||
|
(connection-state-req (thread-cell-ref thread-connection-state)))))])
|
||||||
|
(printf "session-handler ~S~n" (session-handler ses))
|
||||||
|
(output-response
|
||||||
|
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||||
|
(xexpr+extras->xexpr
|
||||||
|
((session-handler ses)
|
||||||
|
(connection-state-req (thread-cell-ref thread-connection-state))))))))]
|
||||||
|
[else
|
||||||
|
(myprint "resume-session: Unknown ses~n")
|
||||||
|
;; TODO: should just start a new session here.
|
||||||
|
(begin-session)]))
|
||||||
|
|
||||||
|
dispatch))
|
||||||
Loading…
Reference in New Issue
Block a user