nomyx-core-1.0.0: src/Nomyx/Core/Test.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Test module
module Nomyx.Core.Test where
import Control.Monad.State
import Control.Exception as E
import Control.Lens
import Language.Haskell.TH hiding (ModuleInfo)
import Language.Haskell.TH.Syntax as THS hiding (lift, Module, ModuleInfo)
import System.IO.Unsafe
import Data.List
import Data.Maybe
import qualified Data.Text.IO as DT
import Data.Acid
import Data.Acid.Memory
import Data.Time hiding (getCurrentTime)
import Paths_nomyx_core as PNC
import System.IO.Temp
import System.FilePath ((</>))
import System.Directory (createDirectoryIfMissing)
import Nomyx.Language hiding (getCurrentTime)
import Nomyx.Core.Types
import Nomyx.Core.Multi
import Nomyx.Core.Session
import Nomyx.Core.Utils
import Nomyx.Core.Profile
import Nomyx.Core.Quotes
import Nomyx.Core.Engine
import qualified Nomyx.Core.Engine as G
import Imprevu.Evaluation
playTests :: Maybe String -> Int -> IO [(String, Bool)]
playTests mTestName delay = do
tests <- case mTestName of
Just testName -> do
let tsts = fatalTests ++ regularTests
return $ maybeToList $ find (\(name, _, _) -> name == testName) tsts
Nothing -> return regularTests
tp <- testProfiles
let session = Session (defaultMulti Settings {_net = defaultNetwork, _mailSettings = (MailSettings False "" "" ""), _adminPassword = "", _saveDir = "", _webDir = "", _sourceDir = "", _watchdog = delay}
(Library [rAutoActivate]
[])) tp
mapM (\(title, t, cond) -> (title,) <$> test title session t cond) tests
defaultNetwork :: Network
defaultNetwork = Network "" 0
-- | test list.
-- each test can be loaded individually in Nomyx with the command line:
-- Nomyx -l <"test name">
regularTests :: [(String, StateT Session IO (), Multi -> Bool)]
regularTests =
[("hello World", gameHelloWorld, condHelloWorld),
("hello World 2 players", gameHelloWorld2Players, condHelloWorld2Players),
("Partial Function 1", gamePartialFunction1, condPartialFunction),
("Partial Function 2", gamePartialFunction2, condPartialFunction),
("Partial Function 3", gamePartialFunction3, condPartialFunction3),
("Test file 1", testFile1, condNRules 2),
("Test file 2", testFile2, condNRules 2),
("Test import Data.Time", testFileTime, condNRules 2),
("load file twice 2", testFileTwice', condNRules 3),
("load file unsafe", testFileUnsafeIO, condNRules 1)] ++
map (\i -> ("Loop" ++ show i, loops !! (i-1), condNoGame)) [1..(length loops)] ++
map (\i -> ("Forbidden" ++ show i, forbiddens !! (i-1), condNRules 1)) [1..(length forbiddens)]
-- Those tests should make the game die immediately because of security problem (it will be re-launched)
fatalTests :: [(String, StateT Session IO (), Multi -> Bool)]
fatalTests = [("Timeout type check", gameBadTypeCheck, const True)]
test :: String -> Session -> StateT Session IO () -> (Multi -> Bool) -> IO Bool
test title session tes cond = do
putStrLn $ "\nPlaying test: " ++ title
m' <- loadTest tes session
(evaluate $ cond m') `E.catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False)
--Loads a test
loadTest :: StateT Session IO () -> Session -> IO Multi
loadTest tes s = do
let delay = _watchdog $ _mSettings $ _multi s
ms <- evalWithWatchdog delay s (evalSession tes) --version with no watchdog: ms <- Just <$> execStateT tes s
case ms of
Just s' -> return $ _multi s'
Nothing -> do
putStrLn "thread timed out, session discarded"
return $ _multi s
testException :: Multi -> SomeException -> IO Multi
testException m e = do
putStrLn $ "Test Exception: " ++ show e
return m
testProfiles :: IO (AcidState ProfileDataState)
testProfiles = openMemoryState initialProfileDataState
printRule :: Q THS.Exp -> String
printRule r = unsafePerformIO $ do
expr <- runQ r
return $ pprint expr
onePlayerOneGame :: StateT Session IO ()
onePlayerOneGame = do
newPlayer 1 PlayerSettings {_pPlayerName = "Player 1", _mail = Nothing, _mailNewInput = False, _mailSubmitRule = False, _mailNewOutput = False, _mailConfirmed = False}
newGame "test" (GameDesc "" "") 1 True
joinGame "test" 1
twoPlayersOneGame :: StateT Session IO ()
twoPlayersOneGame = do
onePlayerOneGame
newPlayer 2 PlayerSettings {_pPlayerName = "Player 2", _mail = Nothing, _mailNewInput = False, _mailSubmitRule = False, _mailNewOutput = False, _mailConfirmed = False}
joinGame "test" 2
submitR :: String -> StateT Session IO ()
submitR r = do
onePlayerOneGame
submitRule (RuleTemplate "" "" r "" Nothing [] []) 1 "test"
testFile' :: FilePath -> FilePath -> String -> StateT Session IO ()
testFile' path name func = do
dataDir <- lift PNC.getDataDir
cont <- liftIO $ DT.readFile (dataDir </> testDir </> path)
updateLibrary 1 (Library [] [ModuleInfo name cont])
submitRule (RuleTemplate "" "" func "" Nothing [] [name]) 1 "test"
testFile :: FilePath -> String -> StateT Session IO ()
testFile name = testFile' name name
-- * Tests
-- ** Standard tests
gameHelloWorld :: StateT Session IO ()
gameHelloWorld = submitR [cr|helloWorld|]
condHelloWorld :: Multi -> Bool
condHelloWorld = isOutput' "hello, world!"
gameHelloWorld2Players :: StateT Session IO ()
gameHelloWorld2Players = do
twoPlayersOneGame
submitRule (RuleTemplate "" "" [cr|helloWorld|] "" Nothing [] []) 1 "test"
condHelloWorld2Players :: Multi -> Bool
condHelloWorld2Players = isOutput' "hello, world!"
condMoneyTransfer :: Multi -> Bool
condMoneyTransfer m = (_vName $ head $ _variables $ firstGame m) == "Accounts"
-- ** Partial functions
partialFunction1 :: String
partialFunction1 = [cr|void $ readVar_ (V "toto1" :: V String)|]
partialFunction2 :: String
partialFunction2 = [cr|void $ do
t <- getCurrentTime
onEventOnce (timeEvent $ addUTCTime 5 t) $ const $ readVar_ (V "toto2")|]
gamePartialFunction1 :: StateT Session IO ()
gamePartialFunction1 = submitR partialFunction1
gamePartialFunction2 :: StateT Session IO ()
gamePartialFunction2 = do
onePlayerOneGame
submitR partialFunction2
gs <- (use $ multi . gameInfos)
let now = _currentTime $ G._game $ _loggedGame $ head gs
return ()
-- zoom multi $ Nomyx.Core.Multi.triggerTimeEvent (5 `addUTCTime` now)
-- triggerTimeEvent defaultEvalConf) (EvalState g 0) ts
-- rule has not been accepted due to exception
condPartialFunction :: Multi -> Bool
condPartialFunction m = (_rStatus $ head $ _rules $ firstGame m) == Active &&
(take 5 $ _lMsg $ head $ _logs $ firstGame m) == "Error"
partialFunction3 :: String
partialFunction3 = [cr|void $ onEvent_ (ruleEvent Proposed) $ const $ readVar_ (V "toto3")|]
gamePartialFunction3 :: StateT Session IO ()
gamePartialFunction3 = do
submitR partialFunction3
submitR [cr|nothing|]
-- rule has been accepted and also next one
condPartialFunction3 :: Multi -> Bool
condPartialFunction3 m = (length $ _rules $ firstGame m) == 3
-- * Malicious codes
--infinite loops: they should be interrupted by the watchdog & resource limits
loops, forbiddens :: [StateT Session IO ()]
loops = [loop1, loop2, loop3, loop4, loop5, loop6, stackOverflow, outputLimit]
forbiddens = [forbid1, forbid2, forbid3, forbid4, forbid5, forbid6]
loop1 = submitR [cr| let x :: Int; x = x in showRule x |]
loop2 = submitR [cr| let f :: Int -> Int; f y = f 1 in showRule (f 1) |]
loop3 = submitR [cr| let x = x + 1 in showRule x |]
loop4 = submitR [cr| let f :: Int -> Int; f x = f $! (x+1) in showRule (f 0) |]
--test stack overflow limits
loop5 = submitR [cr| let x = 1 + x in showRule x |]
loop6 = submitR [cr| let x = array (0::Int, maxBound) [(1000000,'x')] in showRule x |]
-- forbidden codes
forbid1 = submitR "void $ runST (unsafeIOToST (readFile \"/etc/passwd\")) >>= outputAll_"
forbid2 = submitR "void $ unsafeCoerce (readFile \"/etc/passwd\") >>= outputAll_"
forbid3 = submitR "void $ Unsafe.unsafeCoerce (readFile \"/etc/passwd\") >>= outputAll_"
forbid4 = submitR "void $ Foreign.unsafePerformIO $ readFile \"/etc/passwd\" >>= outputAll_"
forbid5 = submitR "void $ Data.ByteString.Internal.inlinePerformIO (readFile \"/etc/passwd\") >>= outputAll_"
forbid6 = submitR "void $ unsafePerformIO (readFile \"/etc/passwd\") >>= outputAll_"
--an expression very long to type check
gameBadTypeCheck :: StateT Session IO ()
gameBadTypeCheck = submitR
"void $ let {p x y f = f x y; f x = p x x} in f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f f)))))))))))))))))) f"
stackOverflow = submitR [cr| let fix f = let x = f x in x in showRule $ foldr (.) id (repeat read) $ fix show |]
outputLimit = submitR [cr| showRule $ repeat 1|]
--the game created should be withdrawn
condNoGame :: Multi -> Bool
condNoGame m = null $ _gameInfos m
-- ** File loading
--standard module
testFile1 :: StateT Session IO ()
testFile1 = do
onePlayerOneGame
testFile "SimpleModule.hs" "myRule"
condNRules :: Int -> Multi -> Bool
condNRules n m = (length $ _rules $ firstGame m) == n
--standard module, call with namespace
testFile2 :: StateT Session IO ()
testFile2 = do
onePlayerOneGame
testFile "SimpleModule.hs" "SimpleModule.myRule"
--module that imports Data.Time (should be Safe in recent versions)
testFileTime :: StateT Session IO ()
testFileTime = do
onePlayerOneGame
testFile "TestTime.hs" "TestTime.myRule"
--loading two modules with the same name is forbidden
testFileTwice :: StateT Session IO ()
testFileTwice = do
onePlayerOneGame
testFile "SimpleModule.hs" "SimpleModule.myRule"
testFile' "more/SimpleModule.hs" "SimpleModule.hs" "SimpleModule.myRule2"
--but having the same function name in different modules is OK
testFileTwice' :: StateT Session IO ()
testFileTwice' = do
onePlayerOneGame
testFile "SimpleModule.hs" "SimpleModule.myRule"
testFile "SimpleModule2.hs" "SimpleModule2.myRule"
--security: no unsafe module imports
testFileUnsafeIO :: StateT Session IO ()
testFileUnsafeIO = do
onePlayerOneGame
testFile "UnsafeIO.hs" "UnsafeIO.myRule"
-- * Helpers
--True if the string in parameter is among the outputs
isOutput' :: String -> Multi -> Bool
isOutput' s m = any (isOutput s . _game . _loggedGame) (_gameInfos m)
firstGame :: Multi -> Game
firstGame = G._game . _loggedGame . head . _gameInfos