#lang scheme/base
(require scheme/contract
net/url
web-server/http
web-server/managers/manager
web-server/servlet
web-server/servlet-env
(planet untyped/unlib:3/keyword)
"base.ss"
"accessor.ss"
"command.ss"
"core.ss"
"selector.ss")
(define (serve/delirium
start
test
#:run-tests? [run-tests? #t]
#:run-tests [run-tests test/text-ui/pause-on-fail]
#:manager [manager #f]
#:port [port 8765]
#:listen-ip [listen-ip "127.0.0.1"]
#:servlet-path [servlet-path "/"]
#:servlet-regexp [servlet-regexp #rx"^."]
#:extra-files-paths [extra-files-paths null]
#:mime-types-path [mime-types-path #f]
#:launch-browser? [launch-browser? #t]
#:file-not-found-responder [file-not-found-responder #f])
(define all-extra-files-paths
`(,delirium-htdocs-path ,@extra-files-paths))
(keyword-apply*
serve/servlet
(if run-tests?
(make-delirium-controller start test run-tests)
start)
`(#:command-line? #t
,@(if manager
`(#:manager ,manager)
null)
#:port ,port
#:listen-ip ,listen-ip
#:servlet-path ,(if run-tests? "/test" servlet-path)
#:servlet-regexp ,servlet-regexp
#:extra-files-paths ,all-extra-files-paths
,@(if mime-types-path
`(#:mime-types-path ,mime-types-path)
null)
#:launch-browser? ,launch-browser?
,@(if file-not-found-responder
`(#:file-not-found-responder ,file-not-found-responder)
null))))
(define (make-delirium-controller servlet-controller test [run-tests test/text-ui/pause-on-fail])
(lambda (request)
(if (regexp-match #rx"^/test" (url->string (request-uri request)))
(run-delirium request test run-tests)
(servlet-controller request))))
(define (run-delirium request test [run-tests test/text-ui/pause-on-fail])
(send-test-page)
(test/delirium request test run-tests)
(send/finish (make-stop-response)))
(define (send-test-page)
(send/suspend/dispatch
(lambda (embed-url)
(make-html-response
(xml (html (@ [xmlns "http://www.w3.org/1999/xhtml"])
(head (script (@ [type "text/javascript"] [src "/scripts/prototype/prototype.js"]))
(script (@ [type "text/javascript"] [src "/scripts/jquery/jquery.js"]))
(script (@ [type "text/javascript"]) ,(js (!dot jQuery (noConflict))))
(script (@ [type "text/javascript"] [src "/scripts/delirium/delirium.js"]))
(script (@ [type "text/javascript"] [src "/scripts/delirium/map.js"]))
(script (@ [type "text/javascript"] [src "/scripts/delirium/accessor.js"]))
(script (@ [type "text/javascript"] [src "/scripts/delirium/command.js"]))
(script (@ [type "text/javascript"] [src "/scripts/delirium/selector.js"]))
(script (@ [type "text/javascript"])
(!raw "\n// <![CDATA[\n")
(!raw ,(js (!dot Event (observe window
"load"
(function ()
(!dot Delirium
(start "target"
,(embed-url (lambda (request) request)))))))))
(!raw "\n// ]]>\n"))
(link (@ [rel "stylesheet"] [type "text/css"] [href "/style/delirium/screen.css"])))
(body (div (@ [id "container"])
(table (@ [id "layout"] [cellspacing "0"] [cellpadding "0"])
(tbody (tr (@ [id "statusrow"])
(td (table (tr (th "Title:")
(td (@ [id "currenttitle"]) " "))
(tr (th "URL:")
(td (tt (@ [id "currenturl"]) " "))))))
(tr (@ [id "targetrow"])
(td (iframe (@ [id "target"]))))
(tr (@ [id "titlerow"])
(th (@ [id "title"])
"Delirium by " (a (@ [href "http://www.untyped.com"])
"Untyped")))))))))))))
(define (default-404-handler request)
(debug "404 not found" (url->string (request-uri request)))
(make-html-response
#:code 404
#:message "Not found"
(xml (html (head (title "404 not found"))
(body (p "Sorry! We could not find that file or resource on our server:")
(blockquote (tt ,(url->string (request-uri request)))))))))
(provide (all-from-out "accessor.ss"
"command.ss"
"selector.ss")
current-delirium-delay
delirium-htdocs-path
schemeunit-test?
javascript?
javascript-expression?
javascript-statement?
test/text-ui/pause-on-fail)
(provide/contract
[serve/delirium (->* ((-> request? response/c) schemeunit-test?)
(#:run-tests? boolean?
#:run-tests (-> any/c any)
#:manager (or/c manager? #f)
#:port natural-number/c
#:listen-ip (or/c string? #f)
#:servlet-path string?
#:servlet-regexp regexp?
#:extra-files-paths (listof path?)
#:mime-types-path path?
#:launch-browser? boolean?
#:file-not-found-responder (or/c (-> request? response/c) false/c))
void?)]
[make-delirium-controller (->* ((-> request? response/c) schemeunit-test?)
((-> schemeunit-test? any))
(-> request? response/c))])