87 lines
3.5 KiB
Scheme
87 lines
3.5 KiB
Scheme
#lang scheme/base
|
|
(require (prefix-in net: (lib "sendurl.ss" "net"))
|
|
(for-syntax scheme/base)
|
|
(lib "list.ss"))
|
|
(require "web-server.ss"
|
|
"configuration/configuration-table.ss"
|
|
"private/util.ss"
|
|
"managers/timeouts.ss"
|
|
"private/servlet.ss"
|
|
"configuration/namespace.ss"
|
|
"private/cache-table.ss"
|
|
(prefix-in servlets: "dispatchers/dispatch-servlets.ss"))
|
|
(require "servlet.ss")
|
|
(provide (rename-out [on-web:syntax on-web])
|
|
send-url
|
|
(all-from-out "servlet.ss"))
|
|
|
|
(define send-url (make-parameter net:send-url))
|
|
|
|
; XXX Change to setup temporary file and special dispatcher
|
|
(define-syntax (on-web:syntax stx)
|
|
(syntax-case stx ()
|
|
[(on-web:syntax servlet-expr)
|
|
(syntax
|
|
(on-web:syntax 8000 servlet-expr))]
|
|
[(on-web:syntax port servlet-expr)
|
|
(with-syntax ([initial-request (datum->syntax (syntax servlet-expr) 'initial-request)])
|
|
(syntax
|
|
(on-web (lambda (initial-request) servlet-expr)
|
|
port
|
|
"servlets/standalone.ss")))]))
|
|
|
|
(define (on-web servlet-expr the-port the-path)
|
|
(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 the-port)])
|
|
(cache-table-lookup! the-scripts
|
|
(string->symbol
|
|
(path->string
|
|
(build-path (directory-part default-configuration-table-path)
|
|
"default-web-root" "."
|
|
the-path)))
|
|
(lambda ()
|
|
(make-servlet (make-custodian)
|
|
(make-servlet-namespace)
|
|
(create-timeout-manager
|
|
(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)) |