1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
module Run.Monad (
TestRun(..),
TestEnv(..),
TestState(..),
TestOptions(..), defaultTestOptions,
Failed(..),
finally,
forkTest,
forkTestUsing,
) where
import Control.Concurrent
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
import Data.Set (Set)
import Data.Text qualified as T
import {-# SOURCE #-} GDB
import Network.Ip
import Output
import {-# SOURCE #-} Process
import Script.Expr
import Script.Object
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
, teNextObjId :: MVar Int
, teProcesses :: MVar [ Process ]
, teGDB :: Maybe (MVar GDB)
}
data TestState = TestState
{ tsGlobals :: GlobalDefs
, tsLocals :: [ ( VarName, SomeVarValue ) ]
, tsDisconnectedUp :: Set NetworkNamespace
, tsDisconnectedBridge :: Set NetworkNamespace
, tsNodePacketLoss :: Map NetworkNamespace Scientific
}
data TestOptions = TestOptions
{ optDefaultTool :: String
, optProcTools :: [(ProcName, String)]
, optTestDir :: FilePath
, optTimeout :: Scientific
, optGDB :: Bool
, optForce :: Bool
, optKeep :: Bool
, optWait :: Bool
}
defaultTestOptions :: TestOptions
defaultTestOptions = TestOptions
{ optDefaultTool = ""
, optProcTools = []
, optTestDir = ".test"
, optTimeout = 1
, optGDB = False
, optForce = False
, optKeep = False
, optWait = False
}
data Failed = Failed
| ProcessCrashed Process
instance MonadFail TestRun where
fail str = do
outLine OutputError Nothing $ T.pack str
throwError Failed
instance MonadError Failed TestRun where
throwError failed = do
failedVar <- asks $ teFailed . fst
liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed)
te <- asks fst
case failed of
ProcessCrashed _ | Just mgdb <- teGDB te -> do
maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb)
_ -> return ()
TestRun $ throwError failed
catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler
instance MonadEval TestRun where
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
instance MonadPIO TestRun where
postpone = liftIO
finally :: MonadError e m => m a -> m b -> m a
finally act handler = do
x <- act `catchError` \e -> handler >> throwError e
void handler
return x
forkTest :: TestRun () -> TestRun ThreadId
forkTest = forkTestUsing forkIO
forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
forkTestUsing fork act = do
tenv <- ask
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 ()
|