Synnefo » snf-ganeti » ganeti-local

	  -osuf $$BINARY.o -hisuf $$BINARY.hi \

	  $(HEXTRA) $(HEXTRA_INT) $@

# for the htools/test binary, we need to enable profiling/coverage

# we compile the hpc-htools binary with the program coverage

htools/hpc-htools: HEXTRA_INT=-fhpc

{-# LANGUAGE TemplateHaskell #-}

{-| Unittests for ganeti-htools.

import Test.QuickCheck

import Text.Printf (printf)

import Data.Maybe

import Control.Monad

import Control.Applicative

allDiskTemplates = [minBound..maxBound]

-- | Null iPolicy, and by null we mean very liberal.

nullIPolicy = Types.IPolicy

  { Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0

                                       , Types.iSpecCpuCount   = 0

failTest msg = printTestCase msg False

-- | Update an instance to be smaller than a node.

setInstanceSmallerThanNode node inst =

  inst { Instance.mem = Node.availMem node `div` 2

       , Instance.dsk = Node.availDisk node `div` 2

       }

-- | Create an instance given its spec.

createInstance mem dsk vcpus =

  Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)

    Types.DTDrbd8 1

-- ** Utils tests

-- | Helper to generate a small string that doesn't contain commas.

genNonCommaString = do

  size <- choose (0, 20) -- arbitrary max size

  vectorOf size (arbitrary `suchThat` ((/=) ','))

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

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

prop_Utils_commaJoinSplit =

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

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

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

-- | Split and join should always be idempotent.

prop_Utils_commaSplitJoin s =

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

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

-- value.

prop_Utils_fromObjWithDefault def_value random_key =

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

  JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]

       random_key (def_value+1) == Just def_value

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

prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop

          tlist = zip (repeat True)  lst2

          cndlist = flist ++ tlist ++ [undefined]

prop_Utils_parseUnit (NonNegative n) =

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

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

  printTestCase "Internal error/overflow?"

    (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.

  property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))

        n_gb = n_mb * 1000

        n_tb = n_gb * 1000

-- ** PeerMap tests

-- | Make sure add is idempotent.

prop_PeerMap_addIdempotent pmap key em =

  fn puniq ==? fn (fn puniq)

          puniq = PeerMap.accumArray const pmap

-- | Make sure remove is idempotent.

prop_PeerMap_removeIdempotent pmap key =

  fn puniq ==? fn (fn puniq)

          puniq = PeerMap.accumArray const pmap

-- | Make sure a missing item returns 0.

prop_PeerMap_findMissing pmap key =

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

-- | Make sure an added item is found.

prop_PeerMap_addFind pmap key em =

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

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

prop_PeerMap_maxElem pmap =

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

                              else (maximum . snd . unzip) puniq

-- | List of tests for the PeerMap module.

testSuite "PeerMap"

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

{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}

prop_Container_addTwo cdata i1 i2 =

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

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

          fn x1 x2 = Container.addTwo x1 x1 x2 x2

prop_Container_nameOf node =

  let nl = makeSmallCluster node 1

      fnode = head (Container.elems nl)

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

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

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

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

prop_Instance_creat inst =

  Instance.name inst ==? Instance.alias inst

prop_Instance_setIdx inst idx =

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

prop_Instance_setName inst name =

  Instance.name newinst == name &&

  Instance.alias newinst == name

prop_Instance_setAlias inst name =

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

  Instance.alias newinst == name

prop_Instance_setPri inst pdx =

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

prop_Instance_setSec inst sdx =

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

prop_Instance_setBoth inst pdx sdx =

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

prop_Instance_shrinkMG inst =

  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

prop_Instance_shrinkMF inst =

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

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

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

prop_Instance_shrinkCG inst =

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

    case Instance.shrinkByType inst Types.FailCPU of

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

      _ -> False

prop_Instance_shrinkCF inst =

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

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

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

prop_Instance_shrinkDG inst =

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

    case Instance.shrinkByType inst Types.FailDisk of

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

      _ -> False

prop_Instance_shrinkDF inst =

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

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

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

prop_Instance_setMovable inst m =

  Instance.movable inst' ==? m

    where inst' = Instance.setMovable inst m

-- Instance text loader tests

prop_Text_Load_Instance name mem dsk vcpus status

                        (NonEmpty pnode) snode

                        (NonNegative pdx) (NonNegative sdx) autobal dt su =

      fail1 = Text.loadInst nl

              [name, mem_s, dsk_s, vcpus_s, status_s,

               sbal, pnode, pnode, tags]

  in case inst of

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

       Types.Ok (_, i) -> printTestCase "Mismatch in some field while\

               Instance.spindleUse i == su &&

               Types.isBad fail1

prop_Text_Load_InstanceFail ktn fields =

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

    case Text.loadInst nl fields of

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

    where nl = Data.Map.fromList ktn

prop_Text_Load_Node name tm nm fm td fd tc fo =

  let conv v = if v < 0

                 then "?"

                Node.fDsk node == fd &&

                Node.tCpu node == fromIntegral tc

prop_Text_Load_NodeFail fields =

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

prop_Text_NodeLSIdempotent node =

  (Text.loadNode defGroupAssoc.

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

    where n = Node.setPolicy Types.defIPolicy $

              node { Node.failN1 = True, Node.offline = False }

prop_Text_ISpecIdempotent ispec =

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

       Text.serializeISpec $ ispec of

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

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

prop_Text_IPolicyIdempotent ipol =

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

       Text.serializeIPolicy owner ipol of

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

prop_Text_CreateSerialise =

  forAll genTags $ \ctags ->

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

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

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

prop_SimuLoad =

  forAll (choose (0, 10)) $ \ngroups ->

  forAll (replicateM ngroups genSimuSpec) $ \specs ->

      mdc_in = concatMap (\(_, n, d, m, c) ->

                            replicate n (fromIntegral m, fromIntegral d,

                                         fromIntegral c,

  in case Simu.parseData strspecs of

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

       Types.Ok (Loader.ClusterData gl nl il tags ipol) ->

-- ** Node tests

prop_Node_setAlias node name =

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

  Node.alias newnode == name

prop_Node_setOffline node status =

  Node.offline newnode ==? status

    where newnode = Node.setOffline node status

prop_Node_setXmem node xm =

  Node.xMem newnode ==? xm

    where newnode = Node.setXmem node xm

prop_Node_setMcpu node mc =

  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.

prop_Node_addPriFM node inst =

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

  not (Instance.isOffline inst) ==>

  case Node.addPri node inst'' of

    Types.OpFail Types.FailMem -> True

    _ -> False

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

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

-- with type FailDisk.

prop_Node_addPriFD node inst =

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

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

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

-- with type FailCPU.

prop_Node_addPriFC =

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

  forAll genOnlineNode $ \node ->

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

-- rejected.

prop_Node_addSec node inst pdx =

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

    not (Instance.isOffline inst)) ||

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

  not (Node.failN1 node) ==>

      isFailure (Node.addSec node inst pdx)

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

-- extra mem/cpu can always be added.

prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

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

-- extra mem/cpu can always be added.

prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

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

-- | Checks for memory reservation changes.

prop_Node_rMem inst =

  not (Instance.isOffline inst) ==>

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

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

-- | Check mdsk setting.

prop_Node_setMdsk node mx =

  Node.loDsk node' >= 0 &&

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

  Node.availDisk node' <= Node.fDsk node' &&

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

  Node.mDsk node' == mx'

          SmallRatio mx' = mx

-- Check tag maps

prop_Node_tagMaps_idempotent =

  forAll genTags $ \tags ->

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

    where m = Data.Map.empty

prop_Node_tagMaps_reject =

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

  let m = Node.addTags Data.Map.empty tags

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

prop_Node_showField node =

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

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

  Node.showField node field /= Types.unknownField

prop_Node_computeGroups nodes =

  let ng = Node.computeGroups nodes

      onlyuuid = map fst ng

     (null nodes || not (null ng))

-- Check idempotence of add/remove operations

prop_Node_addPri_idempotent =

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

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

    _ -> failTest "Can't add instance"

prop_Node_addSec_idempotent =

  forAll genOnlineNode $ \node ->

  forAll (genInstanceSmallerThanNode node) $ \inst ->

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

-- cluster.

prop_Score_Zero node =

  forAll (choose (1, 1024)) $ \count ->

    (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&

  in score <= 1e-12

-- | Check that cluster stats are sane.

prop_CStats_sane =

  forAll (choose (1, 1024)) $ \count ->

  forAll genOnlineNode $ \node ->

-- | Check that one instance is allocated correctly, without

-- rebalances needed.

prop_ClusterAlloc_sane inst =

  forAll (choose (5, 20)) $ \count ->

  forAll genOnlineNode $ \node ->

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

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

  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->

-- | Helper function to create a cluster with the given range of nodes

-- and allocate an instance on it.

genClusterAlloc count node inst =

  let nl = makeSmallCluster node count

      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst

-- | Checks that on a 4-8 node cluster, once we allocate an instance,

-- we can also relocate it.

prop_ClusterAllocRelocate =

  forAll (choose (4, 8)) $ \count ->

  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->

-- | Helper property checker for the result of a nodeEvac or

-- changeGroup operation.

check_EvacMode grp inst result =

  case result of

    Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg

                               failmsg "wrong target group"

                                         (gdx == Group.idx grp)

           v -> failmsg  ("invalid solution: " ++ show v) False

        idx = Instance.idx inst

-- | Checks that on a 4-8 node cluster, once we allocate an instance,

-- we can also node-evacuate it.

prop_ClusterAllocEvacuate =

  forAll (choose (4, 8)) $ \count ->

  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->

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

  forAll (choose (4, 8)) $ \count ->

  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->

-- | Check that allocating multiple instances on a cluster, then

-- adding an empty node, results in a valid rebalance.

prop_ClusterAllocBalance =

  forAll (genNode (Just 5) (Just 128)) $ \node ->

  forAll (choose (3, 5)) $ \count ->

            canBalance tbl True True False

-- | Checks consistency.

prop_ClusterCheckConsistency node inst =

  let nl = makeSmallCluster node 3

      [node1, node2, node3] = Container.elems nl

     (not . null $ ccheck [(0, inst3)])

-- | For now, we only test that we don't lose instances during the split.

prop_ClusterSplitCluster node inst =

  forAll (choose (0, 100)) $ \icnt ->

  let nl = makeSmallCluster node 2

           Just _ -> True

-- | Checks that allocation obeys minimum and maximum instance

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

  -- rqn is the required nodes (1 or 2)

  forAll (choose (1, 2)) $ \rqn ->

-- ** OpCodes tests

-- | Check that opcode serialization is idempotent.

prop_OpCodes_serialization op =

  case J.readJSON (J.showJSON op) of

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

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

testSuite "OpCodes"

            [ 'prop_OpCodes_serialization ]

-- ** Jobs tests

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

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

-- ** Loader tests

prop_Loader_lookupNode ktn inst node =

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

    where nl = Data.Map.fromList ktn

prop_Loader_lookupInstance kti inst =

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

    where il = Data.Map.fromList kti

prop_Loader_assignIndices =

  -- generate nodes with unique names

  forAll (arbitrary `suchThat`

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

-- is zero.

prop_Loader_mergeData ns =

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

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

-- ** Types tests

prop_Types_AllocPolicy_serialisation apol =

  case J.readJSON (J.showJSON apol) of

    J.Ok p -> p ==? apol

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

prop_Types_DiskTemplate_serialisation dt =

  case J.readJSON (J.showJSON dt) of

    J.Ok p -> p ==? dt

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

prop_Types_ISpec_serialisation ispec =

  case J.readJSON (J.showJSON ispec) of

    J.Ok p -> p ==? ispec

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

prop_Types_IPolicy_serialisation ipol =

  case J.readJSON (J.showJSON ipol) of

    J.Ok p -> p ==? ipol

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

prop_Types_EvacMode_serialisation em =

  case J.readJSON (J.showJSON em) of

    J.Ok p -> p ==? em

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

prop_Types_opToResult op =

  case op of

    Types.OpFail _ -> Types.isBad r

                        Types.Bad _ -> False

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

  where r = Types.opToResult op

prop_Types_eitherToResult ei =

  case ei of

    Left _ -> Types.isBad r

                 Types.Bad _ -> False

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

    where r = Types.eitherToResult ei

testSuite "Types"

            [ 'prop_Types_AllocPolicy_serialisation

-- ** CLI tests

-- | Test correct parsing.

prop_CLI_parseISpec descr dsk mem cpu =

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

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

prop_CLI_parseISpecFail descr =

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

  forAll (replicateM nelems arbitrary) $ \values ->

       _ -> property True

-- | Test parseYesNo.

prop_CLI_parseYesNo def testval val =

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

  if testval

              else property $ Types.isBad result

-- | Helper to check for correct parsing of string arg.

checkStringArg val (opt, fn) =

  let GetOpt.Option _ longs _ _ = opt

  in case longs of

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

-- | Test a few string arguments.

prop_CLI_StringArg argument =

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

             , (CLI.oDynuFile,      CLI.optDynuFile)

  in conjoin $ map (checkStringArg argument) args

-- | Helper to test that a given option is accepted OK with quick exit.

checkEarlyExit name options param =

  case CLI.parseOptsInner [param] name options of

    Left (code, _) -> if code == 0

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

-- nothing actually random about this test...

prop_CLI_stdopts =

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

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

instance Arbitrary Ssconf.SSKey where

  arbitrary = elements [minBound..maxBound]

prop_Ssconf_filename key =

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

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