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

Enabling servlets to live anywhere

Browse Source 
svn: r6358
This commit is contained in:
Jay McCarthy 2007-05-28 17:59:26 +00:00
parent b8b0e29437
commit 036ed0c126
3 changed files with 6 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -56,7 +56,7 @@
(lib "request.ss" "web-server" "private"))))
(define/kw (make #:key
[servlet-root "servlets"]
[htdocs-path "servlets"]
[timeouts-servlet-connection (* 60 60 24)]
[responders-servlet-loading
servlet-loading-responder]
@ -99,7 +99,7 @@
(myprint "begin-session~n")
(let ([uri (request-uri req)])
(let-values ([(a-path url-servlet-path url-path-suffix)
(url->servlet-path servlet-root uri)])
(url->servlet-path htdocs-path uri)])
(myprint "a-path = ~s~n" a-path)
(if a-path
(parameterize ([current-directory (directory-part a-path)])

2
collects/web-server/prototype-web-server/private/utils.ss
View File

@ -76,10 +76,12 @@
;; The second value is the prefix of the url-path used to find the servlet.
;; The third value is the remaining suffix of the url-path.
(define (url->servlet-path servlet-dir uri)
(printf "~S~n" `(url->servlet-path ,servlet-dir ,uri))
#;(printf " current-directory = ~s~n" (current-directory))
(let loop ([base-path servlet-dir]
[servlet-path '()]
[path-list (simplify-url-path uri)])
(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list))
(if
(null? path-list)
(values #f #f #f)

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

@ -20,8 +20,8 @@
(define dispatch
(sequencer:make
(filter:make
#rx"^/servlets"
(servlets2:make #:servlet-root (paths-servlet (host-paths host-info))
#rx"\\.ss$"
(servlets2:make #:htdocs-path (paths-htdocs (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))