{-# 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 $ [ "" , "" , "" , "" , "" , "" , "" , "" , "JavaScript Bridge Tests" , "" , "" , "
" , "

JavaScript Bridge Tests

" , "
" , "

Groups

" , "

Tests

" , "

Applicative

" , "

Monad

" , "
" , T.pack (table tests) , "
" , "" , "" , "" ] 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 [ "
" ++ "
" ++ pre ++ "
" ++ "
" ++ tst ++ "
" ++ "
" ++ mon ++ "
" ++ "
" ++ app ++ "
" ++ "
" | (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 = "
" 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