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

conforming to dispatcher pattern

Browse Source 
svn: r6304
This commit is contained in:
Jay McCarthy 2007-05-25 16:54:45 +00:00
parent 878b988b48
commit 3f7fdcac43
2 changed files with 186 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/web-server/prototype-web-server/run.ss
View File

@ -17,8 +17,11 @@
(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)

52
collects/web-server/prototype-web-server/server.ss
View File

@ -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,19 +27,27 @@
(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
[servlet-root "servlets"]
[timeouts-servlet-connection (* 60 60 24)]
[responders-servlet-loading
servlet-loading-responder]
[responders-servlet
(gen-servlet-responder "servlet-error.html")]
[responders-file-not-found
(gen-file-not-found-responder "not-found.html")])
;; ************************************************************ ;; ************************************************************
;; dispatch: connection request host -> void ;; dispatch: connection request host -> void
;; trivial dispatcher ;; trivial dispatcher
(define (dispatch conn req host-info) (define (dispatch conn req)
(define-values (uri method path) (decompose-request req)) (define-values (uri method path) (decompose-request req))
(myprint "dispatch~n") (myprint "dispatch~n")
(if (regexp-match #rx"^/servlets" path) (if (regexp-match #rx"^/servlets" path)
(begin (begin
(adjust-connection-timeout! (adjust-connection-timeout! conn timeouts-servlet-connection)
conn
(timeouts-servlet-connection (host-timeouts host-info)))
;; more here - make timeouts proportional to size of bindings ;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req host-info)) (servlet-content-producer conn req))
(next-dispatcher))) (next-dispatcher)))
;; ************************************************************ ;; ************************************************************
@ -46,7 +55,7 @@
;; SERVING SERVLETS ;; SERVING SERVLETS
;; servlet-content-producer: connection request host -> void ;; servlet-content-producer: connection request host -> void
(define (servlet-content-producer conn req host-info) (define (servlet-content-producer conn req)
(myprint "servlet-content-producer~n") (myprint "servlet-content-producer~n")
(let ([meth (request-method req)]) (let ([meth (request-method req)])
(if (eq? meth 'head) (if (eq? meth 'head)
@ -63,17 +72,16 @@
(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-loading (host-responders host-info)) (responders-servlet-loading uri the-exn)
uri the-exn)
(request-method (request-method
(connection-state-req (connection-state-req
(thread-cell-ref thread-connection-state)))))]) (thread-cell-ref thread-connection-state)))))])
(cond (cond
[(resume-session? uri) [(resume-session? uri)
=> (lambda (session-id) => (lambda (session-id)
(resume-session session-id host-info))] (resume-session session-id))]
[else [else
(begin-session host-info)])))))) (begin-session)]))))))
;; Parameter Parsing ;; Parameter Parsing
@ -112,13 +120,11 @@
;; ************************************************************ ;; ************************************************************
;; begin-session: connection request host-info ;; begin-session: connection request host-info
(define (begin-session host-info) (define (begin-session)
(myprint "begin-session~n") (myprint "begin-session~n")
(let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))]) (let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))])
(let-values ([(a-path url-servlet-path url-path-suffix) (let-values ([(a-path url-servlet-path url-path-suffix)
(url->servlet-path (url->servlet-path servlet-root uri)])
(paths-servlet (host-paths host-info))
uri)])
(myprint "a-path = ~s~n" a-path) (myprint "a-path = ~s~n" a-path)
(if a-path (if a-path
(parameterize ([current-directory (directory-part a-path)]) (parameterize ([current-directory (directory-part a-path)])
@ -136,10 +142,10 @@
(let ([start (dynamic-require module-name 'start)]) (let ([start (dynamic-require module-name 'start)])
(run-start start-servlet start))))) (run-start start-servlet start)))))
(myprint "resume-session~n") (myprint "resume-session~n")
(resume-session (session-id ses) host-info))) (resume-session (session-id ses))))
(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-file-not-found (host-responders host-info)) uri) (responders-file-not-found uri)
(request-method (connection-state-req (thread-cell-ref thread-connection-state)))))))) (request-method (connection-state-req (thread-cell-ref thread-connection-state))))))))
(define to-be-copied-module-specs (define to-be-copied-module-specs
@ -168,7 +174,7 @@
;; ************************************************************ ;; ************************************************************
;; resume-session: connection request number host-info ;; resume-session: connection request number host-info
(define (resume-session ses-id host-info) (define (resume-session ses-id)
; XXX Check if session is for same servlet! ; XXX Check if session is for same servlet!
(myprint "resume-session: ses-id = ~s~n" ses-id) (myprint "resume-session: ses-id = ~s~n" ses-id)
(cond (cond
@ -180,7 +186,7 @@
(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
(request-uri (request-uri
(connection-state-req (connection-state-req
(thread-cell-ref thread-connection-state))) (thread-cell-ref thread-connection-state)))
@ -196,4 +202,6 @@
[else [else
(myprint "resume-session: Unknown ses~n") (myprint "resume-session: Unknown ses~n")
;; TODO: should just start a new session here. ;; TODO: should just start a new session here.
(begin-session host-info)]))) (begin-session)]))
dispatch))