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 dispatch
(sequencer:make
(lambda (conn req)
(prototype:dispatch conn req host-info))
(prototype:make #:servlet-root (paths-servlet (host-paths 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))
#:mime-types-path (paths-mime-types (host-paths 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
(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 "servlet-helpers.ss" "web-server" "private")
(lib "response.ss" "web-server" "private")
@ -7,7 +9,6 @@
(lib "url.ss" "net")
(lib "list.ss")
(lib "plt-match.ss")
(lib "configuration-structures.ss" "web-server" "private")
(lib "dispatch.ss" "web-server" "dispatchers")
(lib "session.ss" "web-server" "prototype-web-server")
(only (lib "abort-resume.ss" "web-server" "prototype-web-server")
@ -18,7 +19,7 @@
"xexpr-extras.ss"
"utils.ss")
(provide dispatch)
(provide make)
(define myprint printf #;(lambda _ (void)))
@ -26,19 +27,27 @@
(define-struct connection-state (conn req))
(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
;; trivial dispatcher
(define (dispatch conn req host-info)
(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 (host-timeouts host-info)))
(adjust-connection-timeout! conn timeouts-servlet-connection)
;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req host-info))
(servlet-content-producer conn req))
(next-dispatcher)))
;; ************************************************************
@ -46,7 +55,7 @@
;; SERVING SERVLETS
;; 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")
(let ([meth (request-method req)])
(if (eq? meth 'head)
@ -63,17 +72,16 @@
(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)
(responders-servlet-loading 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))]
(resume-session session-id))]
[else
(begin-session host-info)]))))))
(begin-session)]))))))
;; Parameter Parsing
@ -112,13 +120,11 @@
;; ************************************************************
;; begin-session: connection request host-info
(define (begin-session 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
(paths-servlet (host-paths host-info))
uri)])
(url->servlet-path servlet-root uri)])
(myprint "a-path = ~s~n" a-path)
(if a-path
(parameterize ([current-directory (directory-part a-path)])
@ -136,10 +142,10 @@
(let ([start (dynamic-require module-name 'start)])
(run-start start-servlet start)))))
(myprint "resume-session~n")
(resume-session (session-id ses) host-info)))
(resume-session (session-id ses))))
(output-response/method
(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))))))))
(define to-be-copied-module-specs
@ -168,7 +174,7 @@
;; ************************************************************
;; 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!
(myprint "resume-session: ses-id = ~s~n" ses-id)
(cond
@ -180,7 +186,7 @@
(lambda (the-exn)
(output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state))
((responders-servlet (host-responders host-info))
(responders-servlet
(request-uri
(connection-state-req
(thread-cell-ref thread-connection-state)))
@ -196,4 +202,6 @@
[else
(myprint "resume-session: Unknown ses~n")
;; TODO: should just start a new session here.
(begin-session host-info)])))
(begin-session)]))
dispatch))