blob: 1481b2b9b8ddbb237ed460fdb52c357f1a97009f (
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
82
83
84
|
module Test (
Test(..),
TestStep(..),
TestBlock(..),
MultiplyTimeout(..),
) where
import Control.Concurrent.MVar
import Control.Monad.Except
import Control.Monad.Reader
import Data.Bifunctor
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 -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
Flush :: Process -> Maybe Regex -> TestStep ()
Guard :: CallStack -> 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 .
(if timeout == 0 then second (+ 1) else first (* timeout))
return $ Object oid $ MultiplyTimeout timeout
| otherwise = do
outLine OutputError Nothing "timeout must not be negative"
throwError Failed
destroyObject Object { objImpl = MultiplyTimeout timeout } = do
var <- asks (teTimeout . fst)
liftIO $ modifyMVar_ var $ return .
(if timeout == 0 then second (subtract 1) else first (/ timeout))
|