blob: 3e98efa23a1affc00aee93c80faa027f6c5075f3 (
plain)
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
|
module Test (
Test(..),
TestStep(..),
TestBlock(..),
MultiplyTimeout(..),
) where
import Control.Concurrent.MVar
import Control.Monad.Except
import Control.Monad.Reader
import Data.Scientific
import Data.Text (Text)
import Data.Typeable
import Network
import Output
import Process
import Run.Monad
import Script.Expr
import Script.Object
import Script.Shell
data Test = Test
{ testName :: Text
, testSteps :: Expr (TestStep ())
}
data TestBlock a where
EmptyTestBlock :: TestBlock ()
TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a
instance Semigroup (TestBlock ()) where
EmptyTestBlock <> block = block
block <> EmptyTestBlock = block
block <> TestBlockStep block' step = TestBlockStep (block <> block') step
instance Monoid (TestBlock ()) where
mempty = EmptyTestBlock
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
SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a
Send :: Process -> Text -> TestStep ()
Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
Flush :: Process -> Maybe Regex -> TestStep ()
Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()
DisconnectNode :: Node -> TestStep a -> TestStep a
DisconnectNodes :: Network -> TestStep a -> TestStep a
DisconnectUpstream :: Network -> TestStep a -> TestStep a
PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a
Wait :: TestStep ()
instance Typeable a => ExprType (TestBlock a) where
textExprType _ = "test block"
textExprValue _ = "<test block>"
data MultiplyTimeout = MultiplyTimeout Scientific
instance ObjectType TestRun MultiplyTimeout where
type ConstructorArgs MultiplyTimeout = Scientific
createObject oid timeout
| timeout > 0 = do
var <- asks (teTimeout . fst)
liftIO $ modifyMVar_ var $ return . (* timeout)
return $ Object oid $ MultiplyTimeout timeout
| otherwise = do
outLine OutputError Nothing "timeout must be positive"
throwError Failed
destroyObject Object { objImpl = MultiplyTimeout timeout } = do
var <- asks (teTimeout . fst)
liftIO $ modifyMVar_ var $ return . (/ timeout)
|