Skip to content
This repository was archived by the owner on Aug 18, 2020. It is now read-only.

Commit 8b76d29

Browse files
KtorZKtorZ
committed
[CO-390] Write a few property-based test for cluster's utils
1 parent 0dc0442 commit 8b76d29

File tree

6 files changed

+644
-1
lines changed

6 files changed

+644
-1
lines changed

‎cluster/cardano-sl-cluster.cabal

+34-1
Original file line numberDiff line numberDiff line change
@@ -62,7 +62,40 @@ library
6262
Cardano.Cluster.Util
6363

6464

65-
executable cardano-sl-demo
65+
test-suite cardano-sl-cluster-test
66+
default-language: Haskell2010
67+
default-extensions: DeriveGeneric
68+
LambdaCase
69+
NoImplicitPrelude
70+
OverloadedStrings
71+
TupleSections
72+
TypeApplications
73+
ScopedTypeVariables
74+
75+
type: exitcode-stdio-1.0
76+
77+
hs-source-dirs: test
78+
main-is: Main.hs
79+
other-modules: Cardano.Cluster.Util.Arbitrary
80+
Cardano.Cluster.Util.Spec
81+
Cardano.Cluster.Environment.Arbitrary
82+
Cardano.Cluster.Environment.Spec
83+
84+
build-depends: base
85+
86+
, cardano-sl-cluster
87+
, cardano-sl-core
88+
, cardano-sl-infra
89+
90+
, async
91+
, containers
92+
, lens
93+
, QuickCheck
94+
, time
95+
, universum
96+
97+
98+
executable cardano-sl-cluster-demo
6699
ghc-options: -threaded -O2 -rtsopts
67100
default-language: Haskell2010
68101
default-extensions: DeriveGeneric

‎cluster/test/Cardano/Cluster/Environment/Arbitrary.hs

+72
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE KindSignatures #-}
5+
{-# LANGUAGE TypeOperators #-}
6+
7+
module Cardano.Cluster.Environment.Arbitrary
8+
(
9+
-- * Types
10+
Cluster (..)
11+
, Port (..)
12+
) where
13+
14+
import Universum
15+
16+
import Test.QuickCheck (Arbitrary (..), elements, listOf1, scale,
17+
shrinkList, suchThat)
18+
19+
import Cardano.Cluster (NodeName (..), NodeType (..))
20+
21+
22+
-- * Types
23+
24+
data Cluster (nodeTypes :: [NodeType]) =
25+
Cluster { getCluster :: [(NodeName, NodeType)] }
26+
deriving (Show)
27+
28+
data Port =
29+
Port { getPort :: Word16 }
30+
deriving (Show)
31+
32+
-- * Instances
33+
34+
instance DemoteNodeTypes nodeTypes => Arbitrary (Cluster nodeTypes) where
35+
arbitrary = do
36+
nodeTypes <- scale (`mod` 10) $ listOf1 $ elements (demoteNodeTypes (Proxy @nodeTypes))
37+
let cluster = evalState (mapM fullyQualifiedNode nodeTypes) 0
38+
return (Cluster cluster)
39+
where
40+
fullyQualifiedNode :: NodeType -> State Int (NodeName, NodeType)
41+
fullyQualifiedNode typ = do
42+
n <- get
43+
put (n + 1)
44+
return $ case typ of
45+
NodeCore -> (NodeName ("core-" <> show n), NodeCore)
46+
NodeRelay -> (NodeName ("relay-" <> show n), NodeRelay)
47+
NodeEdge -> (NodeName ("edge-" <> show n), NodeEdge)
48+
49+
shrink (Cluster xs) =
50+
Cluster <$> filter (not . null) (shrinkList (const []) xs)
51+
52+
instance Arbitrary Port where
53+
arbitrary = Port <$> suchThat arbitrary (< 50000)
54+
shrink _ = []
55+
56+
-- * Internal
57+
58+
-- | Get a value representation of nodeTypes
59+
class DemoteNodeTypes (nodeTypes :: [NodeType]) where
60+
demoteNodeTypes :: Proxy nodeTypes -> [NodeType]
61+
62+
instance DemoteNodeTypes ('[] :: [NodeType]) where
63+
demoteNodeTypes _ = []
64+
65+
instance (DemoteNodeTypes xs) => DemoteNodeTypes ('NodeCore ': xs) where
66+
demoteNodeTypes _ = NodeCore : demoteNodeTypes (Proxy @xs)
67+
68+
instance (DemoteNodeTypes xs) => DemoteNodeTypes ('NodeRelay ': xs) where
69+
demoteNodeTypes _ = NodeRelay : demoteNodeTypes (Proxy @xs)
70+
71+
instance (DemoteNodeTypes xs) => DemoteNodeTypes ('NodeEdge ': xs) where
72+
demoteNodeTypes _ = NodeEdge : demoteNodeTypes (Proxy @xs)

‎cluster/test/Cardano/Cluster/Environment/Spec.hs

+216
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,216 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
4+
module Cardano.Cluster.Environment.Spec
5+
(
6+
-- * Environment
7+
prop_generatedEnvironmentIsValid
8+
9+
-- * Topology
10+
, prop_coresAndRelaysTopologyStatic
11+
, prop_edgesTopologyBehindNat
12+
, prop_edgesConnectedToAllRelays
13+
) where
14+
15+
import Universum
16+
17+
import Control.Lens (at, (?~))
18+
import Data.Map.Strict ((!))
19+
import Test.QuickCheck (Property, classify, conjoin, counterexample,
20+
property, (===), (==>))
21+
22+
import Cardano.Cluster (NodeName (..), NodeType (..))
23+
import Cardano.Cluster.Environment
24+
import Cardano.Cluster.Util (nextNtwrkAddr, ntwrkAddrToString,
25+
unsafeNetworkAddressFromString)
26+
import Pos.Core.NetworkAddress (NetworkAddress)
27+
import Pos.Infra.Network.DnsDomains (DnsDomains (..), NodeAddr (..))
28+
import Pos.Infra.Network.Yaml (Topology (..))
29+
30+
import Cardano.Cluster.Environment.Arbitrary (Cluster (..), Port (..))
31+
import Cardano.Cluster.Util.Arbitrary (SeparatedBy (..))
32+
33+
34+
-- * Environment
35+
36+
prop_generatedEnvironmentIsValid
37+
:: Cluster '[ 'NodeCore, 'NodeRelay, 'NodeEdge ]
38+
-> Maybe Port
39+
-> SeparatedBy "/"
40+
-> Property
41+
prop_generatedEnvironmentIsValid (Cluster nodes) mport (SeparatedBy stateDir) = do
42+
let (cPort, wPort, env0) = case mport of
43+
Nothing -> (3000, 8090, mempty)
44+
Just (Port port) -> (port, port+1000, mempty
45+
& at "LISTEN" ?~ ntwrkAddrToString ("localhost", port)
46+
& at "WALLET_ADDRESS" ?~ ntwrkAddrToString (nextNtwrkAddr 1000 ("localhost", port))
47+
)
48+
49+
let envs = map (\x -> (x, snd $ prepareEnvironment x nodes stateDir env0)) nodes
50+
51+
(length nodes <= 10) ==>
52+
conjoin $ flip map envs $ \((_, nodeType), env) -> case nodeType of
53+
NodeCore -> conjoin
54+
[ prop_commonEnvironment env
55+
, prop_environmentCore env (cPort, Just $ cPort + 100)
56+
]
57+
58+
NodeRelay -> conjoin
59+
[ prop_commonEnvironment env
60+
, prop_environmentRelay env (cPort + 100, Nothing)
61+
]
62+
63+
NodeEdge -> conjoin
64+
[ prop_commonEnvironment env
65+
, prop_environmentEdge env ((wPort, Just $ wPort + 100), (wPort +100, Nothing))
66+
]
67+
where
68+
prop_commonEnvironment env = conjoinWithContext "prop_commonEnvironment"
69+
[ prop_hasEnvVar env "CONFIGURATION_FILE"
70+
, prop_hasEnvVar env "CONFIGURATION_KEY"
71+
, prop_hasEnvVar env "DB_PATH"
72+
, prop_hasEnvVar env "NODE_ID"
73+
, prop_hasEnvVar env "LOG_CONFIG"
74+
, prop_noEnvVar env "LOG_SEVERITY"
75+
, prop_hasEnvVarP env "REBUILD_DB" (`elem` ["True", "False"])
76+
]
77+
78+
prop_environmentCore env portRange = conjoinWithContext "prop_environmentCore"
79+
[ prop_portWithin env "LISTEN" portRange
80+
, prop_noEnvVar env "WALLET_ADDRESS"
81+
, prop_noEnvVar env "WALLET_DOC_ADDRESS"
82+
, prop_noEnvVar env "WALLET_DB_PATH"
83+
, prop_noEnvVar env "WALLET_REBUILD_DB"
84+
, prop_noEnvVar env "NO_CLIENT_AUTH"
85+
, prop_noEnvVar env "TLSCERT"
86+
, prop_noEnvVar env "TLSKEY"
87+
, prop_noEnvVar env "TLSCA"
88+
]
89+
90+
prop_environmentRelay env portRange = conjoinWithContext "prop_environmentRelay"
91+
[ prop_portWithin env "LISTEN" portRange
92+
, prop_noEnvVar env "WALLET_ADDRESS"
93+
, prop_noEnvVar env "WALLET_DOC_ADDRESS"
94+
, prop_noEnvVar env "WALLET_DB_PATH"
95+
, prop_noEnvVar env "WALLET_REBUILD_DB"
96+
, prop_noEnvVar env "NO_CLIENT_AUTH"
97+
, prop_noEnvVar env "TLSCERT"
98+
, prop_noEnvVar env "TLSKEY"
99+
, prop_noEnvVar env "TLSCA"
100+
]
101+
102+
prop_environmentEdge env (apiRange, docRange) = conjoinWithContext "prop_environmentEdge"
103+
[ prop_portWithin env "WALLET_ADDRESS" apiRange
104+
, prop_portWithin env "WALLET_DOC_ADDRESS" docRange
105+
, prop_hasEnvVar env "WALLET_DB_PATH"
106+
, prop_hasEnvVar env "TLSCERT"
107+
, prop_hasEnvVar env "TLSKEY"
108+
, prop_hasEnvVar env "TLSCA"
109+
, prop_hasEnvVarP env "WALLET_REBUILD_DB" (`elem` ["True", "False"])
110+
, prop_hasEnvVarP env "NO_CLIENT_AUTH" (`elem` ["True", "False"])
111+
]
112+
113+
conjoinWithContext :: String -> [String -> Property] -> Property
114+
conjoinWithContext ctx = conjoin . map (\prop -> prop ctx)
115+
116+
prop_hasEnvVarP :: Env -> String -> (String -> Bool) -> String -> Property
117+
prop_hasEnvVarP env var predicate ctx =
118+
case (env ^. at var) of
119+
Nothing ->
120+
counterexample (ctx <> ": ENV var <" <> var <> "> expected but not present in\n" <> show env ) $ False
121+
Just x | not (predicate x) ->
122+
counterexample (ctx <> ": ENV var <" <> var <> "> expected but fails predicate in\n" <> show env ) $ False
123+
Just _ ->
124+
property True
125+
126+
prop_hasEnvVar :: Env -> String -> String -> Property
127+
prop_hasEnvVar env var =
128+
prop_hasEnvVarP env var (/= "")
129+
130+
prop_noEnvVar :: Env -> String -> String -> Property
131+
prop_noEnvVar env var ctx =
132+
case (env ^. at var) of
133+
Just _ ->
134+
counterexample (ctx <> ": ENV var <" <> var <> "> not expected but present in\n" <> show env ) $ False
135+
Nothing ->
136+
property True
137+
138+
prop_portWithin :: Env -> String -> (Word16, Maybe Word16) -> String -> Property
139+
prop_portWithin env var (minPort, mmaxPort) ctx =
140+
let
141+
(_, port) = unsafeNetworkAddressFromString (env ! var)
142+
in
143+
case mmaxPort of
144+
Nothing ->
145+
counterexample (ctx <> ": <" <> show var <> "> should be above "
146+
<> show minPort <> " in " <> show env) $ port >= minPort
147+
148+
Just maxPort ->
149+
counterexample (ctx <> ": <" <> show var <> "> should be within ("
150+
<> show minPort <> ", " <> show maxPort <> ") in " <> show env)
151+
$ port >= minPort && port < maxPort
152+
153+
154+
-- * Topology
155+
156+
prop_coresAndRelaysTopologyStatic
157+
:: Cluster ' [ 'NodeCore, 'NodeRelay ]
158+
-> SeparatedBy "/"
159+
-> Property
160+
prop_coresAndRelaysTopologyStatic (Cluster nodes) =
161+
conjoin . map prop_nodeTopologyIsStatic . getTopologies nodes
162+
where
163+
prop_nodeTopologyIsStatic (_, TopologyStatic{}) = property True
164+
prop_nodeTopologyIsStatic _ = property False
165+
166+
prop_edgesTopologyBehindNat
167+
:: Cluster ' [ 'NodeEdge ]
168+
-> SeparatedBy "/"
169+
-> Property
170+
prop_edgesTopologyBehindNat (Cluster nodes) =
171+
conjoin . map prop_nodeTopologyIsBehindNat . getTopologies nodes
172+
where
173+
prop_nodeTopologyIsBehindNat (_, TopologyBehindNAT {}) = property True
174+
prop_nodeTopologyIsBehindNat _ = property False
175+
176+
prop_edgesConnectedToAllRelays
177+
:: Cluster ' [ 'NodeCore, 'NodeRelay, 'NodeEdge ]
178+
-> SeparatedBy "/"
179+
-> Property
180+
prop_edgesConnectedToAllRelays (Cluster nodes) =
181+
withRelays prop_edgeConnectedToAllRelays . getTopologies nodes
182+
where
183+
withRelays prop topologies =
184+
let
185+
edges =
186+
filter ((== NodeEdge) . (^. _2) . (^. _1)) topologies
187+
relays =
188+
map ((^. _3) . (^. _1)) . filter ((== NodeRelay) . (^. _2) . (^. _1))
189+
$ topologies
190+
in
191+
conjoin $ map (prop relays) edges
192+
193+
prop_edgeConnectedToAllRelays relays (_, TopologyBehindNAT _ _ (DnsDomains [domains])) =
194+
classify (null relays) "no relays" $ sort relays === sort (domainToNtwrkAddr <$> domains)
195+
prop_edgeConnectedToAllRelays _ (_, topology) =
196+
counterexample ("expected TopologyBehindNAT for edge nodes, got:" <> show topology) False
197+
198+
getTopologies
199+
:: [(NodeName, NodeType)]
200+
-> SeparatedBy "/"
201+
-> [((NodeName, NodeType, NetworkAddress), Topology)]
202+
getTopologies nodes (SeparatedBy stateDir) =
203+
zip (zip3 nodeNames nodeTypes nodeAddresses) (extractTopologies envs)
204+
where
205+
(nodeNames, nodeTypes) = unzip nodes
206+
nodeAddresses = extractAddresses envs
207+
envs = map (\x -> prepareEnvironment x nodes stateDir mempty) nodes
208+
extractTopologies = map (getArtifact . (^. _2) . (^. _1))
209+
extractAddresses = map (getNtwrkAddr . (^. _2))
210+
getNtwrkAddr env = fromMaybe
211+
(unsafeNetworkAddressFromString (env ! "WALLET_ADDRESS"))
212+
(unsafeNetworkAddressFromString <$> (env ^. at "LISTEN"))
213+
214+
domainToNtwrkAddr :: NodeAddr a -> NetworkAddress
215+
domainToNtwrkAddr (NodeAddrExact ip (Just port)) = (show ip, port)
216+
domainToNtwrkAddr _ = error "expected only NodeAddrExact constructor with port"

0 commit comments

Comments
 (0)