, testTypes
, testCLI
, testJSON
- , testLUXI
+ , testLuxi
, testSsconf
+ , testRpc
+ , testQlang
) where
+import qualified Test.HUnit as HUnit
import Test.QuickCheck
+import Test.QuickCheck.Monadic (assert, monadicIO, run, stop)
import Text.Printf (printf)
import Data.List (intercalate, nub, isPrefixOf)
import Data.Maybe
+import qualified Data.Set as Set
import Control.Monad
import Control.Applicative
import qualified System.Console.GetOpt as GetOpt
import qualified Text.JSON as J
import qualified Data.Map
import qualified Data.IntMap as IntMap
+import Control.Concurrent (forkIO)
+import Control.Exception (bracket, catchJust)
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.Environment (getEnv)
+import System.Exit (ExitCode(..))
+import System.IO (hClose, openTempFile)
+import System.IO.Error (isEOFErrorType, ioeGetErrorType, isDoesNotExistError)
+import System.Process (readProcessWithExitCode)
import qualified Ganeti.Confd as Confd
import qualified Ganeti.Config as Config
import qualified Ganeti.Daemon as Daemon
import qualified Ganeti.Hash as Hash
+import qualified Ganeti.BasicTypes as BasicTypes
import qualified Ganeti.Jobs as Jobs
import qualified Ganeti.Logging as Logging
import qualified Ganeti.Luxi as Luxi
import qualified Ganeti.Objects as Objects
import qualified Ganeti.OpCodes as OpCodes
-import qualified Ganeti.Query2 as Query2
+import qualified Ganeti.Qlang as Qlang
+import qualified Ganeti.Rpc as Rpc
import qualified Ganeti.Runtime as Runtime
import qualified Ganeti.Ssconf as Ssconf
import qualified Ganeti.HTools.CLI as CLI
failTest :: String -> Property
failTest msg = printTestCase msg False
+-- | Return the python binary to use. If the PYTHON environment
+-- variable is defined, use its value, otherwise use just \"python\".
+pythonCmd :: IO String
+pythonCmd = catchJust (guard . isDoesNotExistError)
+ (getEnv "PYTHON") (const (return "python"))
+
+-- | Run Python with an expression, returning the exit code, standard
+-- output and error.
+runPython :: String -> String -> IO (ExitCode, String, String)
+runPython expr stdin = do
+ py_binary <- pythonCmd
+ readProcessWithExitCode py_binary ["-c", expr] stdin
+
+-- | Check python exit code, and fail via HUnit assertions if
+-- non-zero. Otherwise, return the standard output.
+checkPythonResult :: (ExitCode, String, String) -> IO String
+checkPythonResult (py_code, py_stdout, py_stderr) = do
+ HUnit.assertEqual ("python exited with error: " ++ py_stderr)
+ ExitSuccess py_code
+ return py_stdout
+
-- | Update an instance to be smaller than a node.
setInstanceSmallerThanNode :: Node.Node
-> Instance.Instance -> Instance.Instance
x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
return (DNSChar x)
+instance Show DNSChar where
+ show = show . dnsGetChar
+
-- | Generates a single name component.
getName :: Gen String
getName = do
instance Arbitrary OpCodes.OpCode where
arbitrary = do
- op_id <- elements [ "OP_TEST_DELAY"
- , "OP_INSTANCE_REPLACE_DISKS"
- , "OP_INSTANCE_FAILOVER"
- , "OP_INSTANCE_MIGRATE"
- ]
+ op_id <- elements OpCodes.allOpIDs
case op_id of
"OP_TEST_DELAY" ->
OpCodes.OpTestDelay <$> arbitrary <*> arbitrary
, Types.iPolicySpindleRatio = spindle_ratio
}
+instance Arbitrary Objects.Hypervisor where
+ arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary Objects.PartialNDParams where
+ arbitrary = Objects.PartialNDParams <$> arbitrary <*> arbitrary
+
+instance Arbitrary Objects.Node where
+ arbitrary = Objects.Node <$> getFQDN <*> getFQDN <*> getFQDN
+ <*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN
+ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+ <*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary
+ <*> (Set.fromList <$> genTags)
+
+instance Arbitrary Rpc.RpcCallAllInstancesInfo where
+ arbitrary = Rpc.RpcCallAllInstancesInfo <$> arbitrary
+
+instance Arbitrary Rpc.RpcCallInstanceList where
+ arbitrary = Rpc.RpcCallInstanceList <$> arbitrary
+
+instance Arbitrary Rpc.RpcCallNodeInfo where
+ arbitrary = Rpc.RpcCallNodeInfo <$> arbitrary <*> arbitrary
+
+-- | Custom 'Qlang.Filter' generator (top-level), which enforces a
+-- (sane) limit on the depth of the generated filters.
+genFilter :: Gen Qlang.Filter
+genFilter = choose (0, 10) >>= genFilter'
+
+-- | Custom generator for filters that correctly halves the state of
+-- the generators at each recursive step, per the QuickCheck
+-- documentation, in order not to run out of memory.
+genFilter' :: Int -> Gen Qlang.Filter
+genFilter' 0 =
+ oneof [ return Qlang.EmptyFilter
+ , Qlang.TrueFilter <$> getName
+ , Qlang.EQFilter <$> getName <*> value
+ , Qlang.LTFilter <$> getName <*> value
+ , Qlang.GTFilter <$> getName <*> value
+ , Qlang.LEFilter <$> getName <*> value
+ , Qlang.GEFilter <$> getName <*> value
+ , Qlang.RegexpFilter <$> getName <*> getName
+ , Qlang.ContainsFilter <$> getName <*> value
+ ]
+ where value = oneof [ Qlang.QuotedString <$> getName
+ , Qlang.NumericValue <$> arbitrary
+ ]
+genFilter' n = do
+ oneof [ Qlang.AndFilter <$> vectorOf n'' (genFilter' n')
+ , Qlang.OrFilter <$> vectorOf n'' (genFilter' n')
+ , Qlang.NotFilter <$> genFilter' n'
+ ]
+ where n' = n `div` 2 -- sub-filter generator size
+ n'' = max n' 2 -- but we don't want empty or 1-element lists,
+ -- so use this for and/or filter list length
+
+instance Arbitrary Qlang.ItemType where
+ arbitrary = elements [minBound..maxBound]
+
-- * Actual tests
-- ** Utils tests
-- | We test that in a cluster, given a random node, we can find it by
-- its name and alias, as long as all names and aliases are unique,
-- and that we fail to find a non-existing name.
-prop_Container_findByName :: Node.Node -> Property
-prop_Container_findByName node =
+prop_Container_findByName :: Property
+prop_Container_findByName =
+ forAll (genNode (Just 1) Nothing) $ \node ->
forAll (choose (1, 20)) $ \ cnt ->
forAll (choose (0, cnt - 1)) $ \ fidx ->
forAll (genUniquesList (cnt * 2)) $ \ allnames ->
$ zip names nodes
nl' = Container.fromList nodes'
target = snd (nodes' !! fidx)
- in Container.findByName nl' (Node.name target) == Just target &&
- Container.findByName nl' (Node.alias target) == Just target &&
- isNothing (Container.findByName nl' othername)
+ in Container.findByName nl' (Node.name target) ==? Just target .&&.
+ Container.findByName nl' (Node.alias target) ==? Just target .&&.
+ printTestCase "Found non-existing name"
+ (isNothing (Container.findByName nl' othername))
testSuite "Container"
[ 'prop_Container_addTwo
prop_Text_Load_NodeFail fields =
length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
-prop_Text_NodeLSIdempotent :: Node.Node -> Property
-prop_Text_NodeLSIdempotent node =
- (Text.loadNode defGroupAssoc.
- Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
- Just (Node.name n, n)
- -- override failN1 to what loadNode returns by default
- where n = Node.setPolicy Types.defIPolicy $
- node { Node.failN1 = True, Node.offline = False }
+prop_Text_NodeLSIdempotent :: Property
+prop_Text_NodeLSIdempotent =
+ forAll (genNode (Just 1) Nothing) $ \node ->
+ -- override failN1 to what loadNode returns by default
+ let n = Node.setPolicy Types.defIPolicy $
+ node { Node.failN1 = True, Node.offline = False }
+ in
+ (Text.loadNode defGroupAssoc.
+ Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
+ Just (Node.name n, n)
prop_Text_ISpecIdempotent :: Types.ISpec -> Property
prop_Text_ISpecIdempotent ispec =
-- | Checks that given a set of corrects specs, we can load them
-- successfully, and that at high-level the values look right.
-prop_SimuLoad :: Property
-prop_SimuLoad =
+prop_Simu_Load :: Property
+prop_Simu_Load =
forAll (choose (0, 10)) $ \ngroups ->
forAll (replicateM ngroups genSimuSpec) $ \specs ->
let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d"
replicate ngroups Types.defIPolicy
testSuite "Simu"
- [ 'prop_SimuLoad
+ [ 'prop_Simu_Load
]
-- ** Node tests
-- | Check that the cluster score is close to zero for a homogeneous
-- cluster.
-prop_Score_Zero :: Node.Node -> Property
-prop_Score_Zero node =
+prop_Cluster_Score_Zero :: Node.Node -> Property
+prop_Cluster_Score_Zero node =
forAll (choose (1, 1024)) $ \count ->
(not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
(Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
in score <= 1e-12
-- | Check that cluster stats are sane.
-prop_CStats_sane :: Property
-prop_CStats_sane =
+prop_Cluster_CStats_sane :: Property
+prop_Cluster_CStats_sane =
forAll (choose (1, 1024)) $ \count ->
forAll genOnlineNode $ \node ->
let fn = Node.buildPeers node Container.empty
-- | Check that one instance is allocated correctly, without
-- rebalances needed.
-prop_ClusterAlloc_sane :: Instance.Instance -> Property
-prop_ClusterAlloc_sane inst =
+prop_Cluster_Alloc_sane :: Instance.Instance -> Property
+prop_Cluster_Alloc_sane inst =
forAll (choose (5, 20)) $ \count ->
forAll genOnlineNode $ \node ->
let (nl, il, inst') = makeSmallEmptyCluster node count inst
-- instance spec via tiered allocation (whatever the original instance
-- spec), on either one or two nodes. Furthermore, we test that
-- computed allocation statistics are correct.
-prop_ClusterCanTieredAlloc :: Instance.Instance -> Property
-prop_ClusterCanTieredAlloc inst =
+prop_Cluster_CanTieredAlloc :: Instance.Instance -> Property
+prop_Cluster_CanTieredAlloc inst =
forAll (choose (2, 5)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
let nl = makeSmallCluster node count
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
-- we can also relocate it.
-prop_ClusterAllocRelocate :: Property
-prop_ClusterAllocRelocate =
+prop_Cluster_AllocRelocate :: Property
+prop_Cluster_AllocRelocate =
forAll (choose (4, 8)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
-- we can also node-evacuate it.
-prop_ClusterAllocEvacuate :: Property
-prop_ClusterAllocEvacuate =
+prop_Cluster_AllocEvacuate :: Property
+prop_Cluster_AllocEvacuate =
forAll (choose (4, 8)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
case genClusterAlloc count node inst of
Types.Bad msg -> failTest msg
Types.Ok (nl, il, inst') ->
- conjoin $ map (\mode -> check_EvacMode defGroup inst' $
+ conjoin . map (\mode -> check_EvacMode defGroup inst' $
Cluster.tryNodeEvac defGroupList nl il mode
[Instance.idx inst']) .
evacModeOptions .
-- | Checks that on a 4-8 node cluster with two node groups, once we
-- allocate an instance on the first node group, we can also change
-- its group.
-prop_ClusterAllocChangeGroup :: Property
-prop_ClusterAllocChangeGroup =
+prop_Cluster_AllocChangeGroup :: Property
+prop_Cluster_AllocChangeGroup =
forAll (choose (4, 8)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
-- | Check that allocating multiple instances on a cluster, then
-- adding an empty node, results in a valid rebalance.
-prop_ClusterAllocBalance :: Property
-prop_ClusterAllocBalance =
+prop_Cluster_AllocBalance :: Property
+prop_Cluster_AllocBalance =
forAll (genNode (Just 5) (Just 128)) $ \node ->
forAll (choose (3, 5)) $ \count ->
not (Node.offline node) && not (Node.failN1 node) ==>
canBalance tbl True True False
-- | Checks consistency.
-prop_ClusterCheckConsistency :: Node.Node -> Instance.Instance -> Bool
-prop_ClusterCheckConsistency node inst =
+prop_Cluster_CheckConsistency :: Node.Node -> Instance.Instance -> Bool
+prop_Cluster_CheckConsistency node inst =
let nl = makeSmallCluster node 3
[node1, node2, node3] = Container.elems nl
node3' = node3 { Node.group = 1 }
(not . null $ ccheck [(0, inst3)])
-- | For now, we only test that we don't lose instances during the split.
-prop_ClusterSplitCluster :: Node.Node -> Instance.Instance -> Property
-prop_ClusterSplitCluster node inst =
+prop_Cluster_SplitCluster :: Node.Node -> Instance.Instance -> Property
+prop_Cluster_SplitCluster node inst =
forAll (choose (0, 100)) $ \icnt ->
let nl = makeSmallCluster node 2
(nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
-- times, and generates a random instance that can be allocated on
-- this mini-cluster; it then checks that after applying a policy that
-- the instance doesn't fits, the allocation fails.
-prop_ClusterAllocPolicy :: Node.Node -> Property
-prop_ClusterAllocPolicy node =
+prop_Cluster_AllocPolicy :: Node.Node -> Property
+prop_Cluster_AllocPolicy node =
-- rqn is the required nodes (1 or 2)
forAll (choose (1, 2)) $ \rqn ->
forAll (choose (5, 20)) $ \count ->
in not $ canAllocOn nl rqn inst
testSuite "Cluster"
- [ 'prop_Score_Zero
- , 'prop_CStats_sane
- , 'prop_ClusterAlloc_sane
- , 'prop_ClusterCanTieredAlloc
- , 'prop_ClusterAllocRelocate
- , 'prop_ClusterAllocEvacuate
- , 'prop_ClusterAllocChangeGroup
- , 'prop_ClusterAllocBalance
- , 'prop_ClusterCheckConsistency
- , 'prop_ClusterSplitCluster
- , 'prop_ClusterAllocPolicy
+ [ 'prop_Cluster_Score_Zero
+ , 'prop_Cluster_CStats_sane
+ , 'prop_Cluster_Alloc_sane
+ , 'prop_Cluster_CanTieredAlloc
+ , 'prop_Cluster_AllocRelocate
+ , 'prop_Cluster_AllocEvacuate
+ , 'prop_Cluster_AllocChangeGroup
+ , 'prop_Cluster_AllocBalance
+ , 'prop_Cluster_CheckConsistency
+ , 'prop_Cluster_SplitCluster
+ , 'prop_Cluster_AllocPolicy
]
-- ** OpCodes tests
-- ** Jobs tests
-- | Check that (queued) job\/opcode status serialization is idempotent.
-prop_OpStatus_serialization :: Jobs.OpStatus -> Property
-prop_OpStatus_serialization os =
+prop_Jobs_OpStatus_serialization :: Jobs.OpStatus -> Property
+prop_Jobs_OpStatus_serialization os =
case J.readJSON (J.showJSON os) of
J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok os' -> os ==? os'
-prop_JobStatus_serialization :: Jobs.JobStatus -> Property
-prop_JobStatus_serialization js =
+prop_Jobs_JobStatus_serialization :: Jobs.JobStatus -> Property
+prop_Jobs_JobStatus_serialization js =
case J.readJSON (J.showJSON js) of
J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok js' -> js ==? js'
testSuite "Jobs"
- [ 'prop_OpStatus_serialization
- , 'prop_JobStatus_serialization
+ [ 'prop_Jobs_OpStatus_serialization
+ , 'prop_Jobs_JobStatus_serialization
]
-- ** Loader tests
-- | Check that compareNameComponent on equal strings works.
prop_Loader_compareNameComponent_equal :: String -> Bool
prop_Loader_compareNameComponent_equal s =
- Loader.compareNameComponent s s ==
- Loader.LookupResult Loader.ExactMatch s
+ BasicTypes.compareNameComponent s s ==
+ BasicTypes.LookupResult BasicTypes.ExactMatch s
-- | Check that compareNameComponent on prefix strings works.
prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
- Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
- Loader.LookupResult Loader.PartialMatch s1
+ BasicTypes.compareNameComponent (s1 ++ "." ++ s2) s1 ==
+ BasicTypes.LookupResult BasicTypes.PartialMatch s1
testSuite "Loader"
[ 'prop_Loader_lookupNode
-- * Luxi tests
-instance Arbitrary Luxi.LuxiReq where
+instance Arbitrary Luxi.TagObject where
arbitrary = elements [minBound..maxBound]
-instance Arbitrary Luxi.QrViaLuxi where
+instance Arbitrary Luxi.LuxiReq where
arbitrary = elements [minBound..maxBound]
instance Arbitrary Luxi.LuxiOp where
arbitrary = do
lreq <- arbitrary
case lreq of
- Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> arbitrary
+ Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter
Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
getFields <*> arbitrary
Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
(listOf getFQDN) <*> arbitrary
Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
- Luxi.ReqQueryTags -> Luxi.QueryTags <$> getName <*> getFQDN
+ Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN
Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
(resize maxOpCodes arbitrary)
prop_Luxi_CallEncoding op =
(Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
-testSuite "LUXI"
+-- | Helper to a get a temporary file name.
+getTempFileName :: IO FilePath
+getTempFileName = do
+ tempdir <- getTemporaryDirectory
+ (fpath, handle) <- openTempFile tempdir "luxitest"
+ _ <- hClose handle
+ removeFile fpath
+ return fpath
+
+-- | Server ping-pong helper.
+luxiServerPong :: Luxi.Client -> IO ()
+luxiServerPong c = do
+ msg <- Luxi.recvMsgExt c
+ case msg of
+ Luxi.RecvOk m -> Luxi.sendMsg c m >> luxiServerPong c
+ _ -> return ()
+
+-- | Client ping-pong helper.
+luxiClientPong :: Luxi.Client -> [String] -> IO [String]
+luxiClientPong c =
+ mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
+
+-- | Monadic check that, given a server socket, we can connect via a
+-- client to it, and that we can send a list of arbitrary messages and
+-- get back what we sent.
+prop_Luxi_ClientServer :: [[DNSChar]] -> Property
+prop_Luxi_ClientServer dnschars = monadicIO $ do
+ let msgs = map (map dnsGetChar) dnschars
+ fpath <- run $ getTempFileName
+ -- we need to create the server first, otherwise (if we do it in the
+ -- forked thread) the client could try to connect to it before it's
+ -- ready
+ server <- run $ Luxi.getServer fpath
+ -- fork the server responder
+ _ <- run . forkIO $
+ bracket
+ (Luxi.acceptClient server)
+ (\c -> Luxi.closeClient c >> Luxi.closeServer fpath server)
+ luxiServerPong
+ replies <- run $
+ bracket
+ (Luxi.getClient fpath)
+ Luxi.closeClient
+ (\c -> luxiClientPong c msgs)
+ assert $ replies == msgs
+
+testSuite "Luxi"
[ 'prop_Luxi_CallEncoding
+ , 'prop_Luxi_ClientServer
]
-- * Ssconf tests
testSuite "Ssconf"
[ 'prop_Ssconf_filename
]
+
+-- * Rpc tests
+
+-- | Monadic check that, for an offline node and a call that does not
+-- offline nodes, we get a OfflineNodeError response.
+-- FIXME: We need a way of generalizing this, running it for
+-- every call manually will soon get problematic
+prop_Rpc_noffl_request_allinstinfo :: Rpc.RpcCallAllInstancesInfo -> Property
+prop_Rpc_noffl_request_allinstinfo call =
+ forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do
+ res <- run $ Rpc.executeRpcCall [node] call
+ stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]
+
+prop_Rpc_noffl_request_instlist :: Rpc.RpcCallInstanceList -> Property
+prop_Rpc_noffl_request_instlist call =
+ forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do
+ res <- run $ Rpc.executeRpcCall [node] call
+ stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]
+
+prop_Rpc_noffl_request_nodeinfo :: Rpc.RpcCallNodeInfo -> Property
+prop_Rpc_noffl_request_nodeinfo call =
+ forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do
+ res <- run $ Rpc.executeRpcCall [node] call
+ stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]
+
+testSuite "Rpc"
+ [ 'prop_Rpc_noffl_request_allinstinfo
+ , 'prop_Rpc_noffl_request_instlist
+ , 'prop_Rpc_noffl_request_nodeinfo
+ ]
+
+-- * Qlang tests
+
+-- | Tests that serialisation/deserialisation of filters is
+-- idempotent.
+prop_Qlang_Serialisation :: Property
+prop_Qlang_Serialisation =
+ forAll genFilter $ \flt ->
+ J.readJSON (J.showJSON flt) ==? J.Ok flt
+
+testSuite "Qlang"
+ [ 'prop_Qlang_Serialisation
+ ]
projects / ganeti-local / blobdiff