content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  {-| Unittests for ganeti-htools.
  
  -}
  
  {-
  
  Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are
  met:
  
  1. Redistributions of source code must retain the above copyright notice,
  this list of conditions and the following disclaimer.
  
  2. Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
  IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  -}
  
  module Test.Ganeti.HTools.Node
    ( testHTools_Node
    , Node.Node(..)
    , setInstanceSmallerThanNode
    , genNode
    , genOnlineNode
    , genEmptyOnlineNode
    , genNodeList
    , genUniqueNodeList
    ) where
  
  import Test.QuickCheck
  import Test.HUnit
  
  import Control.Monad
  import qualified Data.Map as Map
  import qualified Data.Graph as Graph
  import Data.List
  
  import Test.Ganeti.TestHelper
  import Test.Ganeti.TestCommon
  import Test.Ganeti.TestHTools
  import Test.Ganeti.HTools.Instance ( genInstanceSmallerThanNode
                                     , genInstanceList
                                     , genInstanceOnNodeList)
  
  import Ganeti.BasicTypes
  import qualified Ganeti.HTools.Loader as Loader
  import qualified Ganeti.HTools.Container as Container
  import qualified Ganeti.HTools.Instance as Instance
  import qualified Ganeti.HTools.Node as Node
  import qualified Ganeti.HTools.Types as Types
  import qualified Ganeti.HTools.Graph as HGraph
  
  {-# ANN module "HLint: ignore Use camelCase" #-}
  
  -- * Arbitrary instances
  
  -- | Generates an arbitrary node based on sizing information.
  genNode :: Maybe Int -- ^ Minimum node size in terms of units
          -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
                       -- just by the max... constants)
          -> Gen Node.Node
  genNode min_multiplier max_multiplier = do
    let (base_mem, base_dsk, base_cpu, base_spindles) =
          case min_multiplier of
            Just mm -> (mm * Types.unitMem,
                        mm * Types.unitDsk,
                        mm * Types.unitCpu,
                        mm)
            Nothing -> (0, 0, 0, 0)
        (top_mem, top_dsk, top_cpu, top_spindles)  =
          case max_multiplier of
            Just mm -> (mm * Types.unitMem,
                        mm * Types.unitDsk,
                        mm * Types.unitCpu,
                        mm)
            Nothing -> (maxMem, maxDsk, maxCpu, maxSpindles)
    name  <- genFQDN
    mem_t <- choose (base_mem, top_mem)
    mem_f <- choose (base_mem, mem_t)
    mem_n <- choose (0, mem_t - mem_f)
    dsk_t <- choose (base_dsk, top_dsk)
    dsk_f <- choose (base_dsk, dsk_t)
    cpu_t <- choose (base_cpu, top_cpu)
    cpu_n <- choose (base_cpu, cpu_t)
    offl  <- arbitrary
    spindles <- choose (base_spindles, top_spindles)
    let n = Node.create name (fromIntegral mem_t) mem_n mem_f
            (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) cpu_n offl spindles
            0 0 False
        n1 = Node.setPolicy nullIPolicy n
        n2 = Loader.updateMemStat n1 Container.empty
    return $ Node.buildPeers n2 Container.empty
  
  -- | Helper function to generate a sane node.
  genOnlineNode :: Gen Node.Node
  genOnlineNode =
    arbitrary `suchThat` (\n -> not (Node.offline n) &&
                                not (Node.failN1 n) &&
                                Node.availDisk n > 2 * Types.unitDsk &&
                                Node.availMem n > 2 * Types.unitMem &&
                                Node.availCpu n > 2 &&
                                Node.tSpindles n > 2)
  
  -- | Helper function to generate a sane empty node with consistent
  -- internal data.
  genEmptyOnlineNode :: Gen Node.Node
  genEmptyOnlineNode =
    (do node <- arbitrary
        let fmem = truncate (Node.tMem node) - Node.nMem node
        let node' = node { Node.offline = False
                         , Node.fMem = fmem
                         , Node.fMemForth = fmem
                         , Node.pMem = fromIntegral fmem / Node.tMem node
                         , Node.pMemForth = fromIntegral fmem / Node.tMem node
                         , Node.rMem = 0
                         , Node.rMemForth = 0
                         , Node.pRem = 0
                         , Node.pRemForth = 0
                         , Node.xMem = 0
                         }
        return node') `suchThat` (\ n -> not (Node.failN1 n) &&
                                         Node.availDisk n > 0 &&
                                         Node.availMem n > 0 &&
                                         Node.availCpu n > 0 &&
                                         Node.tSpindles n > 0)
  
  -- | Generate a node with exclusive storage enabled.
  genExclStorNode :: Gen Node.Node
  genExclStorNode = do
    n <- genOnlineNode
    fs <- choose (Types.unitSpindle, Node.tSpindles n)
    fsForth <- choose (Types.unitSpindle, fs)
    let pd = fromIntegral fs / fromIntegral (Node.tSpindles n)::Double
    let pdForth = fromIntegral fsForth / fromIntegral (Node.tSpindles n)::Double
    return n { Node.exclStorage = True
             , Node.fSpindles = fs
             , Node.fSpindlesForth = fsForth
             , Node.pDsk = pd
             , Node.pDskForth = pdForth
             }
  
  -- | Generate a node with exclusive storage possibly enabled.
  genMaybeExclStorNode :: Gen Node.Node
  genMaybeExclStorNode = oneof [genOnlineNode, genExclStorNode]
  
  -- and a random node
  instance Arbitrary Node.Node where
    arbitrary = genNode Nothing Nothing
  
  -- | Node list generator.
  -- Given a node generator, create a random length node list.  Note that "real"
  -- clusters always have at least one node, so we don't generate empty node
  -- lists here.
  genNodeList :: Gen Node.Node -> Gen Node.List
  genNodeList ngen = fmap (snd . Loader.assignIndices) names_nodes
      where names_nodes = (fmap . map) (\n -> (Node.name n, n)) nodes
            nodes = listOf1 ngen `suchThat`
                    ((\ns -> ns == nub ns) . map Node.name)
  
  -- | Node list generator where node names are unique
  genUniqueNodeList :: Gen Node.Node -> Gen (Node.List, Types.NameAssoc)
  genUniqueNodeList ngen = (do
    nl <- genNodeList ngen
    let na = (fst . Loader.assignIndices) $
             map (\n -> (Node.name n, n)) (Container.elems nl)
    return (nl, na)) `suchThat`
      (\(nl, na) -> Container.size nl == Map.size na)
  
  -- | Generate a node list, an instance list, and a node graph.
  -- We choose instances with nodes contained in the node list.
  genNodeGraph :: Gen (Maybe Graph.Graph, Node.List, Instance.List)
  genNodeGraph = do
    nl <- genNodeList genOnlineNode `suchThat` ((2<=).Container.size)
    il <- genInstanceList (genInstanceOnNodeList nl)
    return (Node.mkNodeGraph nl il, nl, il)
  
  -- * Test cases
  
  prop_setAlias :: Node.Node -> String -> Bool
  prop_setAlias node name =
    Node.name newnode == Node.name node &&
    Node.alias newnode == name
      where newnode = Node.setAlias node name
  
  prop_setOffline :: Node.Node -> Bool -> Property
  prop_setOffline node status =
    Node.offline newnode ==? status
      where newnode = Node.setOffline node status
  
  prop_setMcpu :: Node.Node -> Double -> Property
  prop_setMcpu node mc =
    Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc
      where newnode = Node.setMcpu node mc
  
  -- Check if adding an instance that consumes exactly all reserved
  -- memory does not raise an N+1 error
  prop_addPri_NoN1Fail :: Property
  prop_addPri_NoN1Fail =
    forAll genMaybeExclStorNode $ \node ->
    forAll (genInstanceSmallerThanNode node) $ \inst ->
    let inst' = inst { Instance.mem = Node.fMem node - Node.rMem node }
    in (Node.addPri node inst' /=? Bad Types.FailN1)
  
  -- | Check that an instance add with too high memory or disk will be
  -- rejected.
  prop_addPriFM :: Node.Node -> Instance.Instance -> Property
  prop_addPriFM node inst =
    Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
    Instance.usesMemory inst ==>
    (Node.addPri node inst'' ==? Bad Types.FailMem)
    where inst' = setInstanceSmallerThanNode node inst
          inst'' = inst' { Instance.mem = Instance.mem inst }
  
  -- | Check that adding a primary instance with too much disk fails
  -- with type FailDisk.
  prop_addPriFD :: Instance.Instance -> Property
  prop_addPriFD inst =
    forAll (genNode (Just 1) Nothing) $ \node ->
    forAll (elements Instance.localStorageTemplates) $ \dt ->
    Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
    let inst' = setInstanceSmallerThanNode node inst
        inst'' = inst' { Instance.dsk = Instance.dsk inst
                       , Instance.diskTemplate = dt }
    in (Node.addPri node inst'' ==? Bad Types.FailDisk)
  
  -- | Check if an instance exceeds a spindles limit or has no spindles set.
  hasInstTooManySpindles :: Instance.Instance -> Int -> Bool
  hasInstTooManySpindles inst sp_lim =
    case Instance.getTotalSpindles inst of
      Just s -> s > sp_lim
      Nothing -> True
  
  -- | Check that adding a primary instance with too many spindles fails
  -- with type FailSpindles (when exclusive storage is enabled).
  prop_addPriFS :: Instance.Instance -> Property
  prop_addPriFS inst =
    forAll genExclStorNode $ \node ->
    forAll (elements Instance.localStorageTemplates) $ \dt ->
    hasInstTooManySpindles inst (Node.fSpindles node) &&
      not (Node.failN1 node) ==>
    let inst' = setInstanceSmallerThanNode node inst
        inst'' = inst' { Instance.disks = Instance.disks inst
                       , Instance.diskTemplate = dt }
    in (Node.addPri node inst'' ==? Bad Types.FailSpindles)
  
  -- | Check that adding a primary instance with too many VCPUs fails
  -- with type FailCPU.
  prop_addPriFC :: Property
  prop_addPriFC =
    forAll (choose (1, maxCpu)) $ \extra ->
    forAll genMaybeExclStorNode $ \node ->
    forAll (arbitrary `suchThat` Instance.notOffline
                      `suchThat` (not . Instance.forthcoming)) $ \inst ->
    let inst' = setInstanceSmallerThanNode node inst
        inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
    in case Node.addPri node inst'' of
         Bad Types.FailCPU -> passTest
         v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
  
  -- | Check that an instance add with too high memory or disk will be
  -- rejected.
  prop_addSec :: Node.Node -> Instance.Instance -> Int -> Property
  prop_addSec node inst pdx =
    ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
      not (Instance.isOffline inst)) ||
     Instance.dsk inst >= Node.fDsk node ||
     (Node.exclStorage node &&
      hasInstTooManySpindles inst (Node.fSpindles node))) &&
    not (Node.failN1 node) ==>
        isBad (Node.addSec node inst pdx)
  
  -- | Check that an offline instance with reasonable disk size but
  -- extra mem/cpu can always be added.
  prop_addOfflinePri :: NonNegative Int -> NonNegative Int -> Property
  prop_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =
    forAll genMaybeExclStorNode $ \node ->
    forAll (genInstanceSmallerThanNode node) $ \inst ->
    let inst' = inst { Instance.runSt = Types.StatusOffline
                     , Instance.mem = Node.availMem node + extra_mem
                     , Instance.vcpus = Node.availCpu node + extra_cpu }
    in case Node.addPriEx True node inst' of
         Ok _ -> passTest
         v -> failTest $ "Expected OpGood, but got: " ++ show v
  
  -- | Check that an offline instance with reasonable disk size but
  -- extra mem/cpu can always be added.
  prop_addOfflineSec :: NonNegative Int -> NonNegative Int
                     -> Types.Ndx -> Property
  prop_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
    forAll genMaybeExclStorNode $ \node ->
    forAll (genInstanceSmallerThanNode node) $ \inst ->
    let inst' = inst { Instance.runSt = Types.StatusOffline
                     , Instance.mem = Node.availMem node + extra_mem
                     , Instance.vcpus = Node.availCpu node + extra_cpu
                     , Instance.diskTemplate = Types.DTDrbd8 }
    in case Node.addSec node inst' pdx of
         Ok _ -> passTest
         v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
  
  -- | Checks for memory reservation changes.
  prop_rMem :: Instance.Instance -> Property
  prop_rMem inst =
    not (Instance.isOffline inst) && not (Instance.forthcoming inst) ==>
    -- TODO Should we also require ((> Types.unitMem) . Node.fMemForth) ?
    forAll (genMaybeExclStorNode `suchThat` ((> Types.unitMem) . Node.fMem)) $
      \node ->
    -- ab = auto_balance, nb = non-auto_balance
    -- we use -1 as the primary node of the instance
    let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True
                     , Instance.diskTemplate = Types.DTDrbd8 }
        inst_ab = setInstanceSmallerThanNode node inst'
        inst_nb = inst_ab { Instance.autoBalance = False }
        -- now we have the two instances, identical except the
        -- autoBalance attribute
        orig_rmem = Node.rMem node
        inst_idx = Instance.idx inst_ab
        node_add_ab = Node.addSec node inst_ab (-1)
        node_add_nb = Node.addSec node inst_nb (-1)
        node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
        node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
    in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
         (Ok a_ab, Ok a_nb,
          Ok d_ab, Ok d_nb) ->
           counterexample "Consistency checks failed" $
             Node.rMem a_ab >  orig_rmem &&
             Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
             Node.rMem a_nb == orig_rmem &&
             Node.rMem d_ab == orig_rmem &&
             Node.rMem d_nb == orig_rmem &&
             -- this is not related to rMem, but as good a place to
             -- test as any
             inst_idx `elem` Node.sList a_ab &&
             inst_idx `notElem` Node.sList d_ab
         x -> failTest $ "Failed to add/remove instances: " ++ show x
  
  -- | Check mdsk setting.
  prop_setMdsk :: Node.Node -> SmallRatio -> Bool
  prop_setMdsk node mx =
    Node.loDsk node' >= 0 &&
    fromIntegral (Node.loDsk node') <= Node.tDsk node &&
    Node.availDisk node' >= 0 &&
    Node.availDisk node' <= Node.fDsk node' &&
    fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
    Node.mDsk node' == mx'
      where node' = Node.setMdsk node mx'
            SmallRatio mx' = mx
  
  -- Check tag maps
  prop_tagMaps_idempotent :: Property
  prop_tagMaps_idempotent =
    forAll genTags $ \tags ->
    Node.delTags (Node.addTags m tags) tags ==? m
      where m = Map.empty
  
  prop_tagMaps_reject :: Property
  prop_tagMaps_reject =
    forAll (genTags `suchThat` (not . null)) $ \tags ->
    let m = Node.addTags Map.empty tags
    in all (\t -> Node.rejectAddTags m [t]) tags
  
  prop_showField :: Node.Node -> Property
  prop_showField node =
    forAll (elements Node.defaultFields) $ \ field ->
    fst (Node.showHeader field) /= Types.unknownField &&
    Node.showField node field /= Types.unknownField
  
  prop_computeGroups :: [Node.Node] -> Bool
  prop_computeGroups nodes =
    let ng = Node.computeGroups nodes
        onlyuuid = map fst ng
    in length nodes == sum (map (length . snd) ng) &&
       all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
       length (nub onlyuuid) == length onlyuuid &&
       (null nodes || not (null ng))
  
  -- Check idempotence of add/remove operations
  prop_addPri_idempotent :: Property
  prop_addPri_idempotent =
    forAll genMaybeExclStorNode $ \node ->
    forAll (genInstanceSmallerThanNode node) $ \inst ->
    case Node.addPri node inst of
      Ok node' -> Node.removePri node' inst ==? node
      _ -> failTest "Can't add instance"
  
  prop_addSec_idempotent :: Property
  prop_addSec_idempotent =
    forAll genMaybeExclStorNode $ \node ->
    forAll (genInstanceSmallerThanNode node) $ \inst ->
    let pdx = Node.idx node + 1
        inst' = Instance.setPri inst pdx
        inst'' = inst' { Instance.diskTemplate = Types.DTDrbd8 }
    in case Node.addSec node inst'' pdx of
         Ok node' -> Node.removeSec node' inst'' ==? node
         _ -> failTest "Can't add instance"
  
  -- | Check that no graph is created on an empty node list.
  case_emptyNodeList :: Assertion
  case_emptyNodeList =
    assertEqual "" Nothing $ Node.mkNodeGraph emptynodes emptyinstances
      where emptynodes = Container.empty :: Node.List
            emptyinstances = Container.empty :: Instance.List
  
  -- | Check that the number of vertices of a nodegraph is equal to the number of
  -- nodes in the original node list.
  prop_numVertices :: Property
  prop_numVertices =
    forAll genNodeGraph $ \(graph, nl, _) ->
      (fmap numvertices graph ==? Just (Container.size nl))
      where numvertices = length . Graph.vertices
  
  -- | Check that the number of edges of a nodegraph is equal to twice the number
  -- of instances with secondary nodes in the original instance list.
  prop_numEdges :: Property
  prop_numEdges =
    forAll genNodeGraph $ \(graph, _, il) ->
      (fmap numedges graph ==? Just (numwithsec il * 2))
      where numedges = length . Graph.edges
            numwithsec = length . filter Instance.hasSecondary . Container.elems
  
  -- | Check that a node graph is colorable.
  prop_nodeGraphIsColorable :: Property
  prop_nodeGraphIsColorable =
    forAll genNodeGraph $ \(graph, _, _) ->
      fmap HGraph.isColorable graph ==? Just True
  
  -- | Check that each edge in a nodegraph is an instance.
  prop_instanceIsEdge :: Property
  prop_instanceIsEdge =
    forAll genNodeGraph $ \(graph, _, il) ->
      fmap (\g -> all (`isEdgeOn` g) (iwithsec il)) graph ==? Just True
      where i `isEdgeOn` g = iEdges i `intersect` Graph.edges g == iEdges i
            iEdges i = [ (Instance.pNode i, Instance.sNode i)
                       , (Instance.sNode i, Instance.pNode i)]
            iwithsec = filter Instance.hasSecondary . Container.elems
  
  -- | Check that each instance in an edge in the resulting nodegraph.
  prop_edgeIsInstance :: Property
  prop_edgeIsInstance =
    forAll genNodeGraph $ \(graph, _, il) ->
      fmap (all (`isInstanceIn` il).Graph.edges) graph ==? Just True
        where e `isInstanceIn` il = any (`hasNodes` e) (Container.elems il)
              i `hasNodes` (v1,v2) =
                Instance.allNodes i `elem` permutations [v1,v2]
  
  -- | List of tests for the Node module.
  testSuite "HTools/Node"
              [ 'prop_setAlias
              , 'prop_setOffline
              , 'prop_setMcpu
              , 'prop_addPriFM
              , 'prop_addPriFD
              , 'prop_addPriFS
              , 'prop_addPriFC
              , 'prop_addPri_NoN1Fail
              , 'prop_addSec
              , 'prop_addOfflinePri
              , 'prop_addOfflineSec
              , 'prop_rMem
              , 'prop_setMdsk
              , 'prop_tagMaps_idempotent
              , 'prop_tagMaps_reject
              , 'prop_showField
              , 'prop_computeGroups
              , 'prop_addPri_idempotent
              , 'prop_addSec_idempotent
              , 'case_emptyNodeList
              , 'prop_numVertices
              , 'prop_numEdges
              , 'prop_nodeGraphIsColorable
              , 'prop_edgeIsInstance
              , 'prop_instanceIsEdge
              ]
  