{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad (forever, foldM, void)
import Data.Aeson
import Data.Monoid((<>))
import qualified Data.Text.Lazy as T
import Network.JavaScript as JS
import Network.Wai.Middleware.RequestLogger
import System.Exit
import Web.Scotty hiding (delete, function)
import Data.Time.Clock
main = main_ 3000
main_ :: Int -> IO ()
main_ i = do
lock <- newEmptyMVar
void $ forkIO $ scotty i $ do
-- middleware $ logStdout
middleware $ start $ \ e -> example e `E.finally`
(do putMVar lock ()
putStrLn "Finished example")
get "/" $ do
html $ mconcat $
[
"<!doctype html>"
, "<html lang=\"en\">"
, "<head>"
, "<!-- Required meta tags -->"
, "<meta charset=\"utf-8\">"
, "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1, shrink-to-fit=no\">"
, "<!-- Bootstrap CSS -->"
, "<link rel=\"stylesheet\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css\" integrity=\"sha384-MCw98/SFnGE8fJT3GXwEOngsV7Zt27NXFoaoApmYm81iuXoPkFOJwJ8ERdknLPMO\" crossorigin=\"anonymous\">"
, "<title>JavaScript Bridge Tests</title>"
, "</head>"
, "<body>"
, " <div class=\"container\">"
, "<h3>JavaScript Bridge Tests</h3>"
, " <div class=\"row\">"
, " <div class=\"col-3\"><p class=\"font-weight-bold\">Groups</p></div>"
, " <div class=\"col-5\"><p class=\"font-weight-bold\">Tests</p></div>"
, " <div class=\"col-2\"><p class=\"text-center font-weight-bold\">Applicative</p></div>"
, " <div class=\"col-2\"><p class=\"text-center font-weight-bold\">Monad</p></div>"
, " </div>"
, T.pack (table tests)
, "</div>"
, "<script>"
, "window.jsb = {ws: new WebSocket('ws://' + location.host)};"
, "jsb.ws.onmessage = (evt) => eval(evt.data);"
-- remote object to allow interesting commands and procedures
, "var remote = [];"
, "var stepme = function(dom,s) {"
, " var start = null;"
, " function step(timestamp) {"
, " if (!start) start = timestamp;"
, " if (dom.classList.contains('bg-success') || dom.classList.contains('bg-danger')) return;"
, " var progress = parseInt((timestamp - start) * 100 / (1000 * s));"
, " dom.style.width='' + progress + '%';"
, " dom.innerHTML='' + progress + '%';"
, " if (progress < 100) {"
, " window.requestAnimationFrame(step);"
, " } else {"
, " dom.classList.add('bg-danger');"
, " }"
, " }"
, " requestAnimationFrame(step);"
, "};"
, "</script>"
, "</body>"
, "</html>"
]
takeMVar lock
data Test
= TestA String (forall f . (Command f, Procedure f, Applicative f) => API f -> IO (Maybe String))
| TestM String (forall f . (Command f, Procedure f, Monad f) => API f -> IO (Maybe String))
data Tests = Tests String [Test]
data API f = API
{ send :: forall a . f a -> IO a
, recv :: IO (Result Value)
, progressBar :: RemoteValue DOM
}
data DOM
------------------------------------------------------------------------------
tests :: [Tests]
tests =
[ Tests "Commands"
[ TestA "command" $ \ API{..} -> send (command "1") >> pure Nothing
]
, Tests "Procedures"
[ TestA "procedure 1 + 1" $ \ API{..} -> do
v :: Int <- send (procedure "1+1")
assert v (2 :: Int)
, TestA "procedure 'Hello'" $ \ API{..} -> do
v :: String <- send (procedure "'Hello'")
assert v ("Hello" :: String)
, TestA "procedure [true,false]" $ \ API{..} -> do
v :: [Bool] <- send (procedure "[true,false]")
assert v [True,False]
]
, Tests "Combine Commands / Procedure"
[ TestA "command [] + push" $ \ API{..} -> do
send (command "local = []" *> command "local.push(99)")
v :: [Int] <- send (procedure "local")
assert v [99]
, TestA "command [] + push + procedure" $ \ API{..} -> do
v :: [Int] <- send (command "local = []" *> command "local.push(99)" *> procedure "local")
assert v [99]
, TestA "procedure + procedure" $ \ API{..} -> do
v :: (Int,Bool) <- send (liftA2 (,)
(procedure "99")
(procedure "false"))
assert v (99,False)
]
, Tests "Promises"
[ TestA "promises" $ \ API{..} -> do
v :: (String,String) <- send $ liftA2 (,)
(procedure "new Promise(function(good,bad) { good('Hello') })")
(procedure "new Promise(function(good,bad) { good('World') })")
assert v ("Hello","World")
, TestA "promise + procedure" $ \ API{..} -> do
v :: (String,String) <- send $ liftA2 (,)
(procedure "new Promise(function(good,bad) { good('Hello') })")
(procedure "'World'")
assert v ("Hello","World")
, TestA "good and bad promises" $ \ API{..} -> do
v :: Either JavaScriptException ((String,String,String)) <- E.try $ send $ liftA3 (,,)
(procedure "new Promise(function(good,bad) { good('Hello') })")
(procedure "new Promise(function(good,bad) { bad('Promise Reject') })")
(procedure "new Promise(function(good,bad) { good('News') })")
assert v (Left $ JavaScriptException $ String "Promise Reject")
]
, Tests "Constructors"
[ TestA "constructor" $ \ API{..} -> do
rv :: RemoteValue () <- send $ constructor "'Hello'"
v1 :: String <- send $ procedure (var rv)
send $ delete rv
v2 :: Value <- send $ procedure (var rv)
assert (v1,v2) ("Hello",Null)
]
, Tests "Exceptions"
[ TestA "command throw" $ \ API{..} -> do
send $ command $ "throw 'Command Fail';"
assert () ()
, TestA "procedure throw" $ \ API{..} -> do
v :: Either JavaScriptException Value <- E.try $ send $ procedure $ "(function(){throw 'Command Fail';})()"
assert v (Left $ JavaScriptException $ String "Command Fail")
]
, Tests "Events"
[ TestA "event" $ \ API{..} -> do
send $ command $ event ("Hello, World" :: String)
event <- recv
assert event (Success $ toJSON ("Hello, World" :: String))
]
, Tests "Remote Monad"
[ TestM "remote monad procedure chain" $ \ API{..} -> do
vs :: Value <-
(send $ foldM (\ (r :: Value) (i :: Int) -> procedure $ value r <> "+" <> value i)
(toJSON (0 :: Int))
[0..100])
assert vs (toJSON $ sum [0..100::Int])
, TestM "remote monad constructor chain" $ \ API{..} -> do
rv <- send $ constructor "0"
rv :: RemoteValue () <-
(send $ foldM (\ (r :: RemoteValue ()) (i :: Int) -> constructor $ value r <> "+" <> value i)
rv
[0..100])
v :: Int <- (send $ procedure $ value rv)
assert v (sum [0..100])
]
, Tests "Alive Connection" $
[ TestM "before wait" $ \ API{..} -> do
assert () ()
] ++ [ TestM ("after wait for " ++ show w) $ \ API{..} -> do
send $ command $ "stepme(" <> var progressBar <> "," <> value (fromIntegral w * 1.2 :: Float) <> ")"
_ <- threadDelay $ w * 1000 * 1000
assert () ()
| w <- [3,10,80]
]
]
------------------------------------------------------------------------------
assert :: (Eq a, Show a) => a -> a -> IO (Maybe String)
assert n g
| n == g = return $ Nothing
| otherwise = return $ Just $ show ("assert failure",n,g)
table :: [Tests] -> String
table ts = go0 [] ts
where
go0 p ts = concatMap (\ (t,n) -> go1 (n:p) t) (zip ts [0..])
go1 p (Tests txt ts) = unlines
[ "<div class=\"row\">" ++
"<div class=\"col-3\">" ++
pre ++
"</div>" ++
"<div class=\"col-5\">" ++
tst ++
"</div>" ++
"<div class=\"col-2\">" ++
mon ++
"</div>" ++
"<div class=\"col-2\">" ++
app ++
"</div>" ++
"</div>"
| (t,n) <- ts `zip` [0..]
, let pre | n == 0 = txt
| otherwise = ""
, let (tst,mon,app) = go (n:p) t
]
go p (TestA txt _) = (txt,bar p "a",bar p "m")
go p (TestM txt _) = (txt,"",bar p "m")
bar p a = "<div class=\"progress\"><div id=\"" ++ tag p ++ "-" ++ a ++ "\" class=\"progress-bar\" role=\"progressbar\" style=\"width: 0%;\"></div></div>"
tag :: [Int] -> String
tag p = "tag" ++ concatMap (\ a -> '-' : show a) p
runTest :: Engine -> [Int] -> Test -> IO ()
runTest e p (TestA txt k) = do
recv <- doRecv e
mBar <- JS.send e $ constructor $ JavaScript $ "document.getElementById('" <> T.pack (tag p ++ "-m") <> "')"
aBar <- JS.send e $ constructor $ JavaScript $ "document.getElementById('" <> T.pack (tag p ++ "-a") <> "')"
doTest (API (JS.send e) recv mBar) "-m" p k
doTest (API (JS.sendA e) recv aBar) "-a" p k
runTest e p (TestM txt k) = do
recv <- doRecv e
mBar <- JS.send e $ constructor $ JavaScript $ "document.getElementById('" <> T.pack (tag p ++ "-m") <> "')"
doTest (API (JS.send e) recv mBar) "-m" p k
doRecv :: Engine -> IO (IO (Result Value))
doRecv e = do
return $ do
wait <- registerDelay $ 1000 * 1000
atomically $ (pure . fst <$> readEventChan e)
`orElse` (do b <- readTVar wait ; check b ; return $ Error "timeout!")
doTest :: (Applicative f, Command f) => API f -> String -> [Int] -> (API f -> IO (Maybe String)) -> IO ()
doTest api@API{..} suff p k = do
tm0 <- getCurrentTime
rM <- k api
tm1 <- getCurrentTime
let tm = show (diffUTCTime tm1 tm0)
case rM of
Nothing -> do
send $
(command $ var progressBar <> ".style.width='100%'") *>
(command $ var progressBar <> ".classList.add('bg-success')") *>
(command $ var progressBar <> ".innerHTML=" <> value tm)
Just msg -> do
print ("doTest failed"::String,msg)
send $
(command $ var progressBar <> ".style.width='100%'") *>
(command $ var progressBar <> ".classList.add('bg-danger')") *>
(command $ var progressBar <> ".innerHTML=" <> value tm)
runTests :: Engine -> [Int] -> [Tests] -> IO ()
runTests e p ts = sequence_ [ runTest e (m:n:p) t | (Tests _ ts,n) <- ts `zip` [0..], (t,m) <- ts `zip` [0..] ]
example :: Engine -> IO ()
example e = runTests e [] tests