#lang scheme/base
(require "base.ss")
(require (only-in srfi/1 append-map drop-right)
(only-in srfi/13 string-pad-right)
(prefix-in scheme: scheme/pretty)
web-server/servlet
(mirrors-in)
"json.ss")
(define (test/delirium request test test/ui)
(test/ui test)
(make-stop-response))
(define current-delirium-delay
(make-parameter 0))
(define (delay-command)
(define delay (current-delirium-delay))
(cond [(eq? delay 'keypress) (printf "Press ENTER to continue.")
(flush-output)
(read-line)]
[(zero? delay) (void)]
[else (printf "Waiting for ~a seconds." delay)
(flush-output)
(sleep delay)
(printf "~n")]))
(define (respond/expr generate-expr)
(respond/stmt
(lambda (embed-url)
(define k-url
(embed-url (lambda (request) request)))
(define expr
(generate-expr embed-url))
(js (!dot Delirium (sendResult ,k-url ,expr))))))
(define (respond/stmt generate-stmt)
(define command #f)
(delay-command)
(parse-result
(request-bindings
(send/suspend/dispatch
(lambda (embed-url)
(define k-url
(embed-url (lambda (request) request)))
(define inner-command
(generate-stmt embed-url))
(set! command (js ((function ()
(try (!dot Delirium (log "START" ,(javascript->pretty-string inner-command)))
,inner-command
(!dot Delirium (log "COMPLETE" ,(javascript->pretty-string inner-command)))
(catch exn
(!dot Delirium (log "FAIL" ,(javascript->pretty-string inner-command)))
((!dot Delirium sendExn) ,k-url exn)))))))
(make-js-response command))))
(javascript->pretty-string command)))
(define (make-stop-response)
(make-js-response
(js ((function ()
((!dot Delirium stop)))))))
(define (parse-result bindings command-string)
(define type
(if (exists-binding? 'type bindings)
(string->symbol (extract-binding/single 'type bindings))
(raise-exn exn:fail:browser
"No return type received."
command-string
(void))))
(case type
[(result) (json-result->scheme bindings)]
[(exn) (printf "Command raised browser exn:~n~a~n" command-string)
(raise-exn exn:fail:browser
(format "Exception in browser: ~a" (json-result->string bindings))
command-string
(json-result->scheme bindings))]
[else (printf "Command raised browser exn:~n~a~n" command-string)
(raise-exn exn:fail:browser
(format "Unknown result type: ~s" type)
command-string
(json-result->scheme bindings))]))
(define (json-result->string bindings)
(if (exists-binding? 'json bindings)
(extract-binding/single 'json bindings)
(void)))
(define (json-result->scheme bindings)
(if (exists-binding? 'json bindings)
(let ([json-string (extract-binding/single 'json bindings)])
(with-handlers ([exn? (lambda (exn) (format "Could not parse JSON: ~s" json-string))])
(read-json (open-input-string json-string))))
(void)))
(define (schemeunit-test? item)
(or (schemeunit-test-case? item)
(schemeunit-test-suite? item)))
(define (vector+list->list item)
(if (vector? item)
(vector->list item)
item))
(provide (mirrors-out)
request?
response/full?
send/suspend/dispatch
schemeunit-test?
javascript?
javascript-expression?
javascript-statement?)
(provide/contract
[test/delirium (-> request? schemeunit-test? (-> schemeunit-test? any) response/full?)]
[current-delirium-delay (parameter/c (or/c natural-number/c 'keypress))]
[respond/expr (-> (-> procedure? javascript-expression?) any)]
[respond/stmt (-> (-> procedure? javascript?) any)]
[make-stop-response (-> response/full?)])