{-# 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