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
|
module Run.Monad (
TestRun(..),
TestEnv(..),
TestState(..),
TestOptions(..), defaultTestOptions,
Failed(..),
finally,
forkTest,
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Map (Map)
import Data.Scientific
import qualified Data.Text as T
import {-# SOURCE #-} GDB
import {-# SOURCE #-} Network
import Output
import {-# SOURCE #-} Process
import Test
newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
data TestEnv = TestEnv
{ teOutput :: Output
, teFailed :: TVar (Maybe Failed)
, teOptions :: TestOptions
, teProcesses :: MVar [Process]
, teGDB :: Maybe (MVar GDB)
}
data TestState = TestState
{ tsNetwork :: Network
, tsVars :: [(VarName, SomeVarValue)]
, tsNodePacketLoss :: Map NodeName Scientific
}
data TestOptions = TestOptions
{ optDefaultTool :: String
, optProcTools :: [(ProcName, String)]
, optTestDir :: FilePath
, optTimeout :: Scientific
, optGDB :: Bool
, optForce :: Bool
}
defaultTestOptions :: TestOptions
defaultTestOptions = TestOptions
{ optDefaultTool = ""
, optProcTools = []
, optTestDir = ".test"
, optTimeout = 1
, optGDB = False
, optForce = 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
lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd)
rootNetwork = asks $ tsNetwork . snd
instance MonadOutput TestRun where
getOutput = asks $ teOutput . fst
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 ()
forkTest act = do
tenv <- ask
void $ liftIO $ forkIO $ do
runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
|