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