diff options
Diffstat (limited to 'src/Run')
| -rw-r--r-- | src/Run/Builtins.hs | 43 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 62 |
2 files changed, 90 insertions, 15 deletions
diff --git a/src/Run/Builtins.hs b/src/Run/Builtins.hs new file mode 100644 index 0000000..409e723 --- /dev/null +++ b/src/Run/Builtins.hs @@ -0,0 +1,43 @@ +module Run.Builtins ( + module Run, + loadModules, +) where + +import Data.Proxy +import Data.Scientific +import Data.Text (Text) +import Data.Void + +import Asset (Asset) +import Network (Network, Node) +import Parser (CustomTestError) +import Process (Process) +import Process.Signal (Signal) +import Run +import Script.Expr +import Test (Test, Tag) + + +builtinTypes :: [ SomePrimType ] +builtinTypes = + [ SomePrimType @() Proxy + , SomePrimType @Integer Proxy + , SomePrimType @Scientific Proxy + , SomePrimType @Bool Proxy + , SomePrimType @Text Proxy + , SomePrimType @Void Proxy + , SomePrimType @Regex Proxy + + , SomePrimType @Test Proxy + , SomePrimType @Tag Proxy + , SomePrimType @Asset Proxy + + , SomePrimType @Network Proxy + , SomePrimType @Node Proxy + + , SomePrimType @Process Proxy + , SomePrimType @Signal Proxy + ] + +loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) +loadModules = loadModules' builtinTypes diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 9ec9065..8c772d5 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,9 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, + + getCurrentTimeout, ) where import Control.Concurrent @@ -14,33 +17,43 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Writer import Data.Map (Map) -import Data.Set (Set) import Data.Scientific -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text qualified as T import {-# SOURCE #-} GDB -import {-# SOURCE #-} Network import Network.Ip import Output import {-# SOURCE #-} Process -import Test +import Script.Expr +import Script.Object -newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } - deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) +newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a } + deriving + ( Functor, Applicative, Monad + , MonadReader ( TestEnv, TestState ) + , MonadWriter [ SomeObject TestRun ] + , MonadIO + ) data TestEnv = TestEnv { teOutput :: Output , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions - , teProcesses :: MVar [Process] + , teTestDir :: FilePath + , teNextObjId :: MVar Int + , teNextProcId :: MVar Int + , teProcesses :: MVar [ Process ] + , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) } data TestState = TestState - { tsNetwork :: Network - , tsVars :: [(VarName, SomeVarValue)] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeExpr ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -51,10 +64,14 @@ data TestOptions = TestOptions , optProcTools :: [(ProcName, String)] , optTestDir :: FilePath , optTimeout :: Scientific + , optTcpdump :: Maybe FilePath , optGDB :: Bool , optForce :: Bool , optKeep :: Bool + , optRepeat :: Int + , optKeepGoing :: Bool , optWait :: Bool + , optHookTestResult :: TestName -> Bool -> IO () } defaultTestOptions :: TestOptions @@ -63,10 +80,14 @@ defaultTestOptions = TestOptions , optProcTools = [] , optTestDir = ".test" , optTimeout = 1 + , optTcpdump = Nothing , optGDB = False , optForce = False , optKeep = False + , optRepeat = 1 + , optKeepGoing = False , optWait = False + , optHookTestResult = \_ _ -> return () } data Failed = Failed @@ -93,8 +114,9 @@ instance MonadError Failed TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd) - rootNetwork = asks $ tsNetwork . snd + askGlobalDefs = asks (tsGlobals . snd) + askDictionary = asks (tsLocals . snd) + withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) }) instance MonadOutput TestRun where getOutput = asks $ teOutput . fst @@ -109,10 +131,20 @@ finally act handler = do void handler return x -forkTest :: TestRun () -> TestRun () -forkTest act = do +forkTest :: TestRun () -> TestRun ThreadId +forkTest = forkTestUsing forkIO + +forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId +forkTestUsing fork act = do tenv <- ask - void $ liftIO $ forkIO $ do - runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case + liftIO $ fork $ do + ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act) + case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () + +getCurrentTimeout :: TestRun Scientific +getCurrentTimeout = do + ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst) + return $ if zeros > 0 then 0 + else timeout |