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

Arjun

Browse Source 
svn: r7243
This commit is contained in:
Jay McCarthy 2007-08-31 18:34:08 +00:00
parent ff25adb7d6
commit 9711d10c81
1 changed files with 49 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
collects/web-server/servlet-env.ss
View File

@ -1,14 +1,14 @@
(module servlet-env mzscheme
(require (prefix net: (lib "sendurl.ss" "net"))
(lib "unit.ss"))
(lib "list.ss"))
(require "web-server.ss"
"configuration/configuration-table.ss"
"web-config-unit.ss"
"web-config-sig.ss"
"private/util.ss"
"managers/timeouts.ss"
"private/servlet.ss"
"private/cache-table.ss")
"configuration/namespace.ss"
"private/cache-table.ss"
(prefix servlets: "dispatchers/dispatch-servlets.ss"))
(require "servlet.ss")
(provide (rename on-web:syntax on-web)
send-url
@ -30,39 +30,38 @@
"servlets/standalone.ss")))]))
(define (on-web servlet-expr the-port the-path)
(let* ([standalone-url
(format "http://localhost:~a/~a" the-port the-path)]
[final-value
(void)]
[final-conn
(void)]
[sema
(make-semaphore 0)]
[new-servlet
(lambda (initial-request)
(let ([v (servlet-expr initial-request)])
(set! final-value v)
(semaphore-post sema)
(if (response? v)
v
`(html (head (title "Servlet has ended."))
(body (p "This servlet has ended, please return to the interaction window."))))))]
[shutdown-server
(serve/web-config@ (build-standalone-servlet-configuration the-port the-path new-servlet))])
((send-url) standalone-url #t)
; Wait for final call
(semaphore-wait sema)
; XXX: Find a way to wait for final HTML to be sent
; Shutdown the server
(shutdown-server)
final-value))
(define (build-standalone-servlet-configuration the-port the-path the-servlet)
(let ([basic-configuration@ (configuration-table->web-config@ default-configuration-table-path)]
[the-scripts (make-cache-table)])
(define-values/invoke-unit basic-configuration@
(import)
(export (prefix i: web-config^)))
(let*-values
([(standalone-url)
(format "http://localhost:~a/~a" the-port the-path)]
[(final-value)
(void)]
[(final-conn)
(void)]
[(sema)
(make-semaphore 0)]
[(make-servlet-namespace) (make-make-servlet-namespace)]
[(new-servlet)
(lambda (initial-request)
(let ([v (servlet-expr initial-request)])
(set! final-value v)
(semaphore-post sema)
(if (response? v)
v
`(html (head (title "Servlet has ended."))
(body (p "This servlet has ended, please return to the interaction window."))))))]
[(the-scripts) (make-cache-table)]
[(clear-cache! servlet-dispatch)
(servlets:make (box the-scripts)
#:make-servlet-namespace make-servlet-namespace
#:url->path
(lambda _
(values (build-path (directory-part default-configuration-table-path)
"default-web-root" "."
the-path)
empty)))]
[(shutdown-server)
(serve #:dispatch servlet-dispatch
#:port 9999)])
(cache-table-lookup! the-scripts
(string->symbol
(path->string
@ -71,20 +70,17 @@
the-path)))
(lambda ()
(make-servlet (make-custodian)
(i:make-servlet-namespace)
(make-servlet-namespace)
(create-timeout-manager
(lambda (request)
`(html (head "Return to the interaction window.")
(body (p "Return to the interaction window."))))
30 30)
the-servlet)))
(unit
(import)
(export web-config^)
(define port the-port)
(define max-waiting i:max-waiting)
(define listen-ip i:listen-ip)
(define initial-connection-timeout i:initial-connection-timeout)
(define virtual-hosts i:virtual-hosts)
(define scripts (box the-scripts))
(define make-servlet-namespace i:make-servlet-namespace)))))
(lambda (request)
`(html (head "Return to the interaction window.")
(body (p "Return to the interaction window."))))
30 30)
new-servlet)))
((send-url) standalone-url #t)
; Wait for final call
(semaphore-wait sema)
; XXX: Find a way to wait for final HTML to be sent
; Shutdown the server
(shutdown-server)
final-value)))