Synnefo » snf-ganeti » ganeti-local

-- | Test that signing messages and checking signatures is correct. It

-- also tests, indirectly the serialisation of messages so we don't

-- need a separate test for that.

                         pm crq =

  forAll (choose (0, fromIntegral C.confdMaxClockSkew)) $ \ good_delta ->

  let encoded = J.encode crq

-- | Tests that signing with a different key fails detects failure

-- correctly.

  -- fixme: we hardcode here the expected length of a sha1 key, as

  -- otherwise we could have two short keys that differ only in the

  -- final zero elements count, and those will be expanded to be the

     Confd.Utils.parseRequest key_verify encoded

testSuite "ConfdUtils"

  ]

import qualified Ganeti.HTools.Types as Types

-- | Test correct parsing.

  let str = printf "%d,%d,%d" dsk mem cpu::String

  in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)

-- | Test parsing failure due to wrong section count.

  forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->

  forAll (replicateM nelems arbitrary) $ \values ->

  let str = intercalate "," $ map show (values::[Int])

       _ -> property True

-- | Test parseYesNo.

  forAll (elements [val, "yes", "no"]) $ \actual_val ->

  if testval

    then CLI.parseYesNo def Nothing ==? Types.Ok def

           Right (options, _) -> fn options ==? Just val

-- | Test a few string arguments.

  let args = [ (CLI.oDataFile,      CLI.optDataFile)

             , (CLI.oDynuFile,      CLI.optDynuFile)

             , (CLI.oSaveCluster,   CLI.optSaveCluster)

-- | Test that all binaries support some common options. There is

-- nothing actually random about this test...

  let params = ["-h", "--help", "-V", "--version"]

      opts = map (\(name, (_, o)) -> (name, o)) Program.personalities

      -- apply checkEarlyExit across the cartesian product of params and opts

  in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]

testSuite "CLI"

          ]

-- | Check that the cluster score is close to zero for a homogeneous

-- cluster.

  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.

  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.

  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.

  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.

  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.

  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 with two node groups, once we

-- allocate an instance on the first node group, we can also change

-- its group.

  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.

  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.

  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.

  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.

  -- 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"

            ]

import qualified Ganeti.HTools.Node as Node

-- we silence the following due to hlint bug fixed in later versions

  fn i1 i2 cont == fn i2 i1 cont &&

  fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)

    where cont = foldl (\c x -> Container.add x x c) Container.empty cdata

          fn x1 x2 = Container.addTwo x1 x1 x2 x2

  let nl = makeSmallCluster node 1

      fnode = head (Container.elems nl)

  in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode

-- | 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.

  forAll (genNode (Just 1) Nothing) $ \node ->

  forAll (choose (1, 20)) $ \ cnt ->

  forAll (choose (0, cnt - 1)) $ \ fidx ->

       (isNothing (Container.findByName nl' othername))

testSuite "Container"

            ]

-- Simple instance tests, we only have setter/getters

  Instance.name inst ==? Instance.alias inst

  Instance.idx (Instance.setIdx inst idx) ==? idx

  Instance.name newinst == name &&

  Instance.alias newinst == name

    where newinst = Instance.setName inst name

  Instance.name newinst == Instance.name inst &&

  Instance.alias newinst == name

    where newinst = Instance.setAlias inst name

  Instance.pNode (Instance.setPri inst pdx) ==? pdx

  Instance.sNode (Instance.setSec inst sdx) ==? sdx

  Instance.pNode si == pdx && Instance.sNode si == sdx

    where si = Instance.setBoth inst pdx sdx

  Instance.mem inst >= 2 * Types.unitMem ==>

    case Instance.shrinkByType inst Types.FailMem of

      Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem

      _ -> False

  forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->

    let inst' = inst { Instance.mem = mem}

    in Types.isBad $ Instance.shrinkByType inst' Types.FailMem

  Instance.vcpus inst >= 2 * Types.unitCpu ==>

    case Instance.shrinkByType inst Types.FailCPU of

      Types.Ok inst' ->

        Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu

      _ -> False

  forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->

    let inst' = inst { Instance.vcpus = vcpus }

    in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU

  Instance.dsk inst >= 2 * Types.unitDsk ==>

    case Instance.shrinkByType inst Types.FailDisk of

      Types.Ok inst' ->

        Instance.dsk inst' == Instance.dsk inst - Types.unitDsk

      _ -> False

  forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->

    let inst' = inst { Instance.dsk = dsk }

    in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk

  Instance.movable inst' ==? m

    where inst' = Instance.setMovable inst m

testSuite "Instance"

            ]

import qualified Ganeti.HTools.Node as Node

import qualified Ganeti.HTools.Types as Types

  Loader.lookupNode nl inst node ==? Map.lookup node nl

    where nl = Map.fromList ktn

  Loader.lookupInstance il inst ==? Map.lookup inst il

    where il = Map.fromList kti

  -- generate nodes with unique names

  forAll (arbitrary `suchThat`

          (\nodes ->

-- | Checks that the number of primary instances recorded on the nodes

-- is zero.

  let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns

  in case Loader.mergeData [] [] [] []

         (Loader.emptyCluster {Loader.cdNodes = na}) of

         null instances

-- | Check that compareNameComponent on equal strings works.

  BasicTypes.compareNameComponent s s ==

    BasicTypes.LookupResult BasicTypes.ExactMatch s

-- | Check that compareNameComponent on prefix strings works.

  BasicTypes.compareNameComponent (s1 ++ "." ++ s2) s1 ==

    BasicTypes.LookupResult BasicTypes.PartialMatch s1

testSuite "Loader"

            ]

-- * Test cases

  Node.name newnode == Node.name node &&

  Node.alias newnode == name

    where newnode = Node.setAlias node name

  Node.offline newnode ==? status

    where newnode = Node.setOffline node status

  Node.xMem newnode ==? xm

    where newnode = Node.setXmem node xm

  Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc

    where newnode = Node.setMcpu node mc

-- | Check that an instance add with too high memory or disk will be

-- rejected.

  Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&

  not (Instance.isOffline inst) ==>

  case Node.addPri node inst'' of

-- | Check that adding a primary instance with too much disk fails

-- with type FailDisk.

  forAll (elements Instance.localStorageTemplates) $ \dt ->

  Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>

  let inst' = setInstanceSmallerThanNode node inst

-- | Check that adding a primary instance with too many VCPUs fails

-- with type FailCPU.

  forAll (choose (1, maxCpu)) $ \extra ->

  forAll genOnlineNode $ \node ->

  forAll (arbitrary `suchThat` Instance.notOffline) $ \inst ->

-- | Check that an instance add with too high memory or disk will be

-- rejected.

  ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&

    not (Instance.isOffline inst)) ||

   Instance.dsk inst >= Node.fDsk node) &&

-- | Check that an offline instance with reasonable disk size but

-- extra mem/cpu can always be added.

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

  let inst' = inst { Instance.runSt = Types.AdminOffline

-- | Check that an offline instance with reasonable disk size but

-- extra mem/cpu can always be added.

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

  let inst' = inst { Instance.runSt = Types.AdminOffline

       v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v

-- | Checks for memory reservation changes.

  not (Instance.isOffline inst) ==>

  forAll (genOnlineNode `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->

  -- ab = auto_balance, nb = non-auto_balance

       x -> failTest $ "Failed to add/remove instances: " ++ show x

-- | Check mdsk setting.

  Node.loDsk node' >= 0 &&

  fromIntegral (Node.loDsk node') <= Node.tDsk node &&

  Node.availDisk node' >= 0 &&

          SmallRatio mx' = mx

-- Check tag maps

  forAll genTags $ \tags ->

  Node.delTags (Node.addTags m tags) tags ==? m

    where m = Map.empty

  forAll (genTags `suchThat` (not . null)) $ \tags ->

  let m = Node.addTags Map.empty tags

  in all (\t -> Node.rejectAddTags m [t]) tags

  forAll (elements Node.defaultFields) $ \ field ->

  fst (Node.showHeader field) /= Types.unknownField &&

  Node.showField node field /= Types.unknownField

  let ng = Node.computeGroups nodes

      onlyuuid = map fst ng

  in length nodes == sum (map (length . snd) ng) &&

     (null nodes || not (null ng))

-- Check idempotence of add/remove operations

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

  case Node.addPri node inst of

    Types.OpGood node' -> Node.removePri node' inst ==? node

    _ -> failTest "Can't add instance"

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

  let pdx = Node.idx node + 1

       _ -> failTest "Can't add instance"

testSuite "Node"

            ]

import qualified Ganeti.HTools.PeerMap as PeerMap

-- | Make sure add is idempotent.

  fn puniq ==? fn (fn puniq)

    where fn = PeerMap.add key em

          puniq = PeerMap.accumArray const pmap

-- | Make sure remove is idempotent.

  fn puniq ==? fn (fn puniq)

    where fn = PeerMap.remove key

          puniq = PeerMap.accumArray const pmap

-- | Make sure a missing item returns 0.

  PeerMap.find key (PeerMap.remove key puniq) ==? 0

    where puniq = PeerMap.accumArray const pmap

-- | Make sure an added item is found.

                     -> PeerMap.Key -> PeerMap.Elem -> Property

  PeerMap.find key (PeerMap.add key em puniq) ==? em

    where puniq = PeerMap.accumArray const pmap

-- | Manual check that maxElem returns the maximum indeed, or 0 for null.

  PeerMap.maxElem puniq ==? if null puniq then 0

                              else (maximum . snd . unzip) puniq

    where puniq = PeerMap.accumArray const pmap

-- | List of tests for the PeerMap module.

testSuite "PeerMap"

            ]

-- | Checks that given a set of corrects specs, we can load them

-- successfully, and that at high-level the values look right.

  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"

            ]

-- * Instance text loader tests

  pnode /= snode && pdx /= sdx ==>

  let vcpus_s = show vcpus

      dsk_s = show dsk

               Instance.spindleUse i == su &&

               Types.isBad fail1

  length fields /= 10 && length fields /= 11 ==>

    case Text.loadInst nl fields of

      Types.Ok _ -> failTest "Managed to load instance from invalid data"

                       "Invalid/incomplete instance data: '" `isPrefixOf` msg

    where nl = Map.fromList ktn

  let conv v = if v < 0

                 then "?"

                 else show v

                Node.fDsk node == fd &&

                Node.tCpu node == fromIntegral tc

  length fields /= 8 ==> isNothing $ Text.loadNode Map.empty fields

  forAll (genNode (Just 1) Nothing) $ \node ->

  -- override failN1 to what loadNode returns by default

  let n = Node.setPolicy Types.defIPolicy $

         Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?

    Just (Node.name n, n)

  case Text.loadISpec "dummy" . Utils.sepSplit ',' .

       Text.serializeISpec $ ispec of

    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg

    Types.Ok ispec' -> ispec ==? ispec'

  case Text.loadIPolicy . Utils.sepSplit '|' $

       Text.serializeIPolicy owner ipol of

    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg

-- allocations, not for the business logic). As such, it's a quite

-- complex and slow test, and that's the reason we restrict it to

-- small cluster sizes.

  forAll genTags $ \ctags ->

  forAll (choose (1, 20)) $ \maxiter ->

  forAll (choose (2, 10)) $ \count ->

                nl' ==? nl2

testSuite "Text"

            ]

-- * Test cases

  case J.readJSON (J.showJSON apol) of

    J.Ok p -> p ==? apol

    J.Error s -> failTest $ "Failed to deserialise: " ++ s

  case J.readJSON (J.showJSON dt) of

    J.Ok p -> p ==? dt

    J.Error s -> failTest $ "Failed to deserialise: " ++ s

  case J.readJSON (J.showJSON ispec) of

    J.Ok p -> p ==? ispec

    J.Error s -> failTest $ "Failed to deserialise: " ++ s

  case J.readJSON (J.showJSON ipol) of

    J.Ok p -> p ==? ipol

    J.Error s -> failTest $ "Failed to deserialise: " ++ s

  case J.readJSON (J.showJSON em) of

    J.Ok p -> p ==? em

    J.Error s -> failTest $ "Failed to deserialise: " ++ s

  case op of

    Types.OpFail _ -> Types.isBad r

    Types.OpGood v -> case r of

                        Types.Ok v' -> v == v'

  where r = Types.opToResult op

  case ei of

    Left _ -> Types.isBad r

    Right v -> case r of

    where r = Types.eitherToResult ei

testSuite "Types"

            ]

-- | If the list is not just an empty element, and if the elements do

-- not contain commas, then join+split should be idempotent.

  forAll (choose (0, 20)) $ \llen ->

  forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->

  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst

-- | Split and join should always be idempotent.

  Utils.commaJoin (Utils.sepSplit ',' s) ==? s

-- | fromObjWithDefault, we test using the Maybe monad and an integer

-- value.

  -- a missing key will be returned with the default

  JSON.fromObjWithDefault [] random_key def_value == Just def_value &&

  -- a found key will be returned as is, not with default

       random_key (def_value+1) == Just def_value

-- | Test that functional if' behaves like the syntactic sugar if.

  Utils.if' cnd a b ==? if cnd then a else b

-- | Test basic select functionality

  Utils.select def (flist ++ tlist) ==? expectedresult

    where expectedresult = Utils.if' (null lst2) def (head lst2)

          flist = zip (repeat False) lst1

          tlist = zip (repeat True)  lst2

-- | Test basic select functionality with undefined default

  Utils.select undefined (flist ++ tlist) ==? head lst2

    where flist = zip (repeat False) lst1

          tlist = zip (repeat True)  lst2

-- | Test basic select functionality with undefined list values

  Utils.select undefined cndlist ==? head lst2

    where flist = zip (repeat False) lst1

          tlist = zip (repeat True)  lst2

          cndlist = flist ++ tlist ++ [undefined]

  Utils.parseUnit (show n) ==? Types.Ok n .&&.

  Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.

  Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.

-- | Test list for the Utils module.

testSuite "Utils"

            ]

import qualified Ganeti.BasicTypes as BasicTypes

import qualified Ganeti.JSON as JSON

  let arr = map J.showJSON intarr in

  case JSON.toArray (J.JSArray arr) of

    BasicTypes.Ok arr' -> arr ==? arr'

    BasicTypes.Bad err -> failTest $ "Failed to parse array: " ++ err

  -- poor man's instance Arbitrary JSValue

  forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item ->

  case JSON.toArray item of

    BasicTypes.Ok result -> failTest $ "Unexpected parse, got " ++ show result

testSuite "JSON"

          ]

-- * Test cases

-- | Check that (queued) job\/opcode status serialization is idempotent.

  case J.readJSON (J.showJSON os) of

    J.Error e -> failTest $ "Cannot deserialise: " ++ e

    J.Ok os' -> os ==? os'

  case J.readJSON (J.showJSON js) of

    J.Error e -> failTest $ "Cannot deserialise: " ++ e

    J.Ok js' -> js ==? js'

testSuite "Jobs"

            ]

      Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary

-- | Simple check that encoding/decoding of LuxiOp works.

  (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Ok op

-- | Helper to a get a temporary file name.

-- | 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.

  let msgs = map (map dnsGetChar) dnschars

  fpath <- run $ getTempFileName

  -- we need to create the server first, otherwise (if we do it in the

  stop $ replies ==? msgs

testSuite "Luxi"

          ]

              <*> (Set.fromList <$> genTags)

-- | Tests that fillDict behaves correctly

  let d_map = Map.fromList defaults

      d_keys = map fst defaults

      c_map = Map.fromList custom

      (Objects.fillDict d_map c_map (d_keys++c_keys) == Map.empty)

testSuite "Objects"

  ]

-- * Test cases

-- | Check that opcode serialization is idempotent.

  case J.readJSON (J.showJSON op) of

    J.Error e -> failTest $ "Cannot deserialise: " ++ e

    J.Ok op' -> op ==? op'

-- | Check that Python and Haskell defined the same opcode list.

  py_stdout <- runPython "from ganeti import opcodes\n\

                         \print '\\n'.join(opcodes.OP_MAPPING.keys())" "" >>=

               checkPythonResult

-- a better way to do this, for example by having a

-- separately-launched Python process (if not running the tests would

-- be skipped).

  let num_opcodes = length OpCodes.allOpIDs * 500

  sample_opcodes <- sample' (vectorOf num_opcodes

                             (arbitrary::Gen OpCodes.OpCode))

        ) $ zip opcodes decoded

testSuite "OpCodes"

            ]

-- | Tests that serialisation/deserialisation of filters is

-- idempotent.

  forAll genFilter $ \flt ->

  J.readJSON (J.showJSON flt) ==? J.Ok flt

  printTestCase "failed JSON encoding"

    (J.readJSON (J.showJSON rex) ==? J.Ok rex) .&&.

  printTestCase "failed read/show instances" (read (show rex) ==? rex)

testSuite "Qlang"

  ]

-- 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

  forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do

      res <- run $ Rpc.executeRpcCall [node] call

      stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]

  forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do

      res <- run $ Rpc.executeRpcCall [node] call

      stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]

  forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do

      res <- run $ Rpc.executeRpcCall [node] call

      stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]

testSuite "Rpc"

  ]

instance Arbitrary Ssconf.SSKey where

  arbitrary = elements [minBound..maxBound]

  printTestCase "Key doesn't start with correct prefix" $

    Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key

testSuite "Ssconf"

  ]

import Test.QuickCheck

import Language.Haskell.TH

-- | Tries to drop a prefix from a string.

simplifyName :: String -> String -> String

simplifyName pfx string = fromMaybe string (stripPrefix pfx string)

-- | Builds a test from a QuickCheck property.

-- | Builds a test for a HUnit test case.

-- | Runs the correct test provider for a given test, based on its

-- name (not very nice, but...).

  let str = nameBase name

      nameE = varE name

      strE = litE (StringL str)

  in case () of

         | otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'"

-- | Builds a test suite.

testSuite :: String -> [Name] -> Q [Dec]

testSuite tsname tdef = do

  let fullname = mkName $ "test" ++ tsname

  sigtype <- [t| (String, [Test]) |]

  return [ SigD fullname sigtype

         , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),