diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/Run.hs | 20 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 17 | ||||
| -rw-r--r-- | src/Script/Object.hs | 42 | ||||
| -rw-r--r-- | src/Test.hs | 3 |
5 files changed, 76 insertions, 7 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index bf3c9ef..9b7b755 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -65,6 +65,7 @@ executable erebos-tester Script.Expr Script.Expr.Class Script.Module + Script.Object Script.Shell Script.Var Test @@ -12,15 +12,16 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Fix import Control.Monad.Reader +import Control.Monad.Writer import Data.Bifunctor import Data.Map qualified as M import Data.Maybe +import Data.Proxy import Data.Scientific import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T -import Text.Megaparsec (errorBundlePretty, showErrorComponent) import System.Directory import System.Exit @@ -29,6 +30,8 @@ import System.Posix.Process import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent) + import GDB import Network import Network.Ip @@ -38,6 +41,7 @@ import Process import Run.Monad import Script.Expr import Script.Module +import Script.Object import Script.Shell import Test import Test.Builtins @@ -53,6 +57,7 @@ runTest out opts gdefs test = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 procVar <- newMVar [] mgdb <- if optGDB opts @@ -65,6 +70,7 @@ runTest out opts gdefs test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar , teGDB = fst <$> mgdb } @@ -94,7 +100,7 @@ runTest out opts gdefs test = do oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing resetOutputTime out - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do withInternet $ \_ -> do runStep =<< eval (testSteps test) when (optWait opts) $ do @@ -144,7 +150,15 @@ runBlock (TestBlockStep prev step) = runBlock prev >> runStep step runStep :: TestStep () -> TestRun () runStep = \case Scope block -> do - runBlock block + ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left) + mapM_ destroySomeObject (reverse objs) + either throwError return x + + CreateObject (Proxy :: Proxy o) cargs -> do + objIdVar <- asks (teNextObjId . fst) + oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x )) + obj <- createObject @TestRun @o (ObjectId oid) cargs + tell [ toSomeObject obj ] Subnet name parent inner -> do withSubnet parent (Just name) $ runStep . inner diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index abef32d..aeab7e4 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -15,6 +15,7 @@ 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.Scientific @@ -26,15 +27,22 @@ import Network.Ip import Output import {-# SOURCE #-} Process 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] + , teNextObjId :: MVar Int + , teProcesses :: MVar [ Process ] , teGDB :: Maybe (MVar GDB) } @@ -117,6 +125,7 @@ forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId forkTestUsing fork act = do tenv <- ask liftIO $ fork $ do - runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case + ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act) + case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () diff --git a/src/Script/Object.hs b/src/Script/Object.hs new file mode 100644 index 0000000..9232b21 --- /dev/null +++ b/src/Script/Object.hs @@ -0,0 +1,42 @@ +module Script.Object ( + ObjectId(..), + ObjectType(..), + Object(..), SomeObject(..), + toSomeObject, fromSomeObject, + destroySomeObject, +) where + +import Data.Kind +import Data.Typeable + + +newtype ObjectId = ObjectId Int + +class Typeable a => ObjectType m a where + type ConstructorArgs a :: Type + type ConstructorArgs a = () + + createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) + destroyObject :: Object m a -> m () + +data Object m a = ObjectType m a => Object + { objId :: ObjectId + , objImpl :: a + } + +data SomeObject m = forall a. ObjectType m a => SomeObject + { sobjId :: ObjectId + , sobjImpl :: a + } + +toSomeObject :: Object m a -> SomeObject m +toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl } + +fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a) +fromSomeObject SomeObject {..} = do + let objId = sobjId + objImpl <- cast sobjImpl + return Object {..} + +destroySomeObject :: SomeObject m -> m () +destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl) diff --git a/src/Test.hs b/src/Test.hs index a9a2cdb..6c44e94 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -10,7 +10,9 @@ import Data.Typeable import Network import Process +import Run.Monad import Script.Expr +import Script.Object import Script.Shell data Test = Test @@ -32,6 +34,7 @@ instance Monoid (TestBlock ()) where data TestStep a where Scope :: TestBlock a -> TestStep a + CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep () Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a |