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

Fiddling with requires

Browse Source 
svn: r6388
This commit is contained in:
Jay McCarthy 2007-05-29 20:37:08 +00:00
parent 31d07ed30e
commit 861a1c1ef5
5 changed files with 33 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -1,18 +1,17 @@
(module dispatch-servlets2 mzscheme (module dispatch-servlets2 mzscheme
(require (lib "kw.ss") (require (lib "kw.ss")
(lib "contract.ss") (lib "contract.ss")
(lib "connection-manager.ss" "web-server" "private")
(lib "request-structs.ss" "web-server")
(lib "response-structs.ss" "web-server")
(lib "response.ss" "web-server" "private")
(lib "util.ss" "web-server" "private")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "dispatch.ss" "web-server" "dispatchers") (lib "request-structs.ss" "web-server")
(lib "session.ss" "web-server" "prototype-web-server" "private") (lib "session.ss" "web-server" "prototype-web-server" "private")
(only "private/web.ss" (only "private/web.ss"
initialize-servlet) initialize-servlet)
(lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api") (lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api")
"../dispatchers/dispatch.ss"
"../private/connection-manager.ss"
"../private/util.ss"
"../private/response.ss"
"../private/configuration.ss" "../private/configuration.ss"
"private/utils.ss") "private/utils.ss")
@ -20,8 +19,6 @@
[interface-version dispatcher-interface-version?]) [interface-version dispatcher-interface-version?])
(provide make) (provide make)
(define myprint printf #;(lambda _ (void)))
(define top-cust (current-custodian)) (define top-cust (current-custodian))
(define make-servlet-namespace (define make-servlet-namespace
@ -46,40 +43,29 @@
;; dispatch : connection request -> void ;; dispatch : connection request -> void
(define (dispatch conn req) (define (dispatch conn req)
(define uri (request-uri req))
(adjust-connection-timeout! conn timeouts-servlet-connection) (adjust-connection-timeout! conn timeouts-servlet-connection)
;; XXX - make timeouts proportional to size of bindings ;; XXX - make timeouts proportional to size of bindings
(myprint "servlet-content-producer~n") (with-handlers ([void
(let ([meth (request-method req)]) (lambda (the-exn)
(if (eq? meth 'head) (output-response/method
(output-response/method conn
conn (responders-servlet-loading uri the-exn)
(make-response/full (request-method req)))])
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE (cond
'() (list "ignored")) [(extract-session uri)
meth) => (lambda (session-id)
(let ([uri (request-uri req)]) (resume-session session-id conn req))]
(with-handlers ([void [else
(lambda (the-exn) (begin-session conn req)])))
(output-response/method
conn
(responders-servlet-loading uri the-exn)
(request-method req)))])
(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 Currently there are just sessions, should be servlets and sessions
;; begin-session: connection request ;; begin-session: connection request
(define (begin-session conn req) (define (begin-session conn req)
(myprint "begin-session~n")
(let ([uri (request-uri req)]) (let ([uri (request-uri req)])
(let-values ([(a-path url-servlet-path url-path-suffix) (let-values ([(a-path url-servlet-path url-path-suffix)
(url->servlet-path htdocs-path uri)]) (url->servlet-path htdocs-path uri)])
(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)])
(let* ([cust (make-custodian top-cust)] (let* ([cust (make-custodian top-cust)]
@ -89,11 +75,9 @@
[current-namespace ns] [current-namespace ns]
[current-session ses]) [current-session ses])
(let ([module-name `(file ,(path->string a-path))]) (let ([module-name `(file ,(path->string a-path))])
(myprint "dynamic-require ...~n")
(let ([start (dynamic-require module-name 'start)]) (let ([start (dynamic-require module-name 'start)])
(set-session-servlet! ses (set-session-servlet! ses
(initialize-servlet start))))) (initialize-servlet start)))))
(myprint "resume-session~n")
(resume-session (session-id ses) (resume-session (session-id ses)
conn req))) conn req)))
(output-response/method (output-response/method
@ -120,12 +104,11 @@
(if (string=? s r) (if (string=? s r)
(loop rp sp) (loop rp sp)
#f)])]))) #f)])])))
(myprint "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans) #;(printf "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans)
ans) ans)
;; resume-session: number connection request ;; resume-session: number connection request
(define (resume-session ses-id conn req) (define (resume-session ses-id conn req)
(myprint "resume-session: ses-id = ~s~n" ses-id)
(cond (cond
[(lookup-session ses-id) [(lookup-session ses-id)
=> (lambda (ses) => (lambda (ses)
@ -138,12 +121,10 @@
conn conn
(responders-servlet (request-uri req) the-exn) (responders-servlet (request-uri req) the-exn)
(request-method req)))]) (request-method req)))])
(myprint "session-handler ~S~n" (session-servlet ses))
(output-response conn (output-response conn
((session-servlet ses) req)))) ((session-servlet ses) req))))
(begin-session conn req)))] (begin-session conn req)))]
[else [else
(myprint "resume-session: Unknown ses~n")
(begin-session conn req)])) (begin-session conn req)]))
dispatch)) dispatch))

10
collects/web-server/prototype-web-server/lang-api.ss
View File

@ -1,7 +1,7 @@
(module lang-api mzscheme (module lang-api mzscheme
(require (lib "request-structs.ss" "web-server") (require (lib "url.ss" "net")
(lib "response-structs.ss" "web-server") "../request-structs.ss"
(lib "url.ss" "net") "../response-structs.ss"
"private/abort-resume.ss" "private/abort-resume.ss"
"private/web.ss" "private/web.ss"
"lang-api/web-cells.ss" "lang-api/web-cells.ss"
@ -9,9 +9,9 @@
"lang-api/file-box.ss" "lang-api/file-box.ss"
"lang-api/web-extras.ss") "lang-api/web-extras.ss")
(provide (all-from-except mzscheme #%module-begin) (provide (all-from-except mzscheme #%module-begin)
(all-from (lib "request-structs.ss" "web-server"))
(all-from (lib "response-structs.ss" "web-server"))
(all-from (lib "url.ss" "net")) (all-from (lib "url.ss" "net"))
(all-from "../request-structs.ss")
(all-from "../response-structs.ss")
(all-from "private/abort-resume.ss") (all-from "private/abort-resume.ss")
(all-from "private/web.ss") (all-from "private/web.ss")
(all-from "lang-api/web-cells.ss") (all-from "lang-api/web-cells.ss")

4
collects/web-server/prototype-web-server/lang-api/web-extras.ss
View File

@ -3,9 +3,9 @@
(lib "etc.ss") (lib "etc.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "base64.ss" "net") (lib "base64.ss" "net")
(lib "request-structs.ss" "web-server")
(lib "response-structs.ss" "web-server")
(lib "url.ss" "net") (lib "url.ss" "net")
"../../request-structs.ss"
"../../response-structs.ss"
"../private/web.ss") "../private/web.ss")
(provide send/suspend/dispatch (provide send/suspend/dispatch
redirect/get) redirect/get)

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

@ -1,8 +1,8 @@
(module session mzscheme (module session mzscheme
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "request-structs.ss" "web-server") "../../response.ss"
(lib "response.ss" "web-server") "../../request-structs.ss"
"url-param.ss") "url-param.ss")
(provide current-session) (provide current-session)
@ -48,7 +48,7 @@
;; encode-session : url number -> url ;; encode-session : url number -> url
(define (encode-session a-url ses-id) (define (encode-session a-url ses-id)
(insert-param a-url "s" (number->string ses-id))) (insert-param a-url "s" (number->string ses-id)))
;; extract-session : url -> (union number #f) ;; extract-session : url -> (union number #f)
;; Determine if the url encodes a session-id and extract it ;; Determine if the url encodes a session-id and extract it
(define (extract-session a-url) (define (extract-session a-url)

9
collects/web-server/prototype-web-server/private/web.ss
View File

@ -2,9 +2,8 @@
(require (lib "serialize.ss") (require (lib "serialize.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "request-structs.ss" "web-server") "../../request-structs.ss"
(rename "abort-resume.ss" send/suspend0 send/suspend) "abort-resume.ss"
(all-except "abort-resume.ss" send/suspend)
"session.ss" "session.ss"
"stuff-url.ss" "stuff-url.ss"
"url-param.ss") "url-param.ss")
@ -37,7 +36,7 @@
;; send/suspend/hidden: (url input-field -> response) -> request ;; send/suspend/hidden: (url input-field -> response) -> request
;; like send/suspend except the continuation is encoded in a hidden field ;; like send/suspend except the continuation is encoded in a hidden field
(define (send/suspend/hidden page-maker) (define (send/suspend/hidden page-maker)
(send/suspend0 (send/suspend
(lambda (k) (lambda (k)
(let ([p-cont (serialize k)]) (let ([p-cont (serialize k)])
(page-maker (page-maker
@ -47,7 +46,7 @@
;; send/suspend/url: (url -> response) -> request ;; send/suspend/url: (url -> response) -> request
;; like send/suspend except the continuation is encoded in the url ;; like send/suspend except the continuation is encoded in the url
(define (send/suspend/url page-maker) (define (send/suspend/url page-maker)
(send/suspend0 (send/suspend
(lambda (k) (lambda (k)
(page-maker (page-maker
(stuff-url (serialize k) (stuff-url (serialize k)