content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  {-| Unittests for ganeti-htools.
  
  -}
  
  {-
  
  Copyright (C) 2009, 2010, 2011, 2012 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.Cluster (testHTools_Cluster) where
  
  import Test.QuickCheck hiding (Result)
  
  import Control.Monad (liftM)
  import qualified Data.IntMap as IntMap
  import Data.Maybe
  
  import Test.Ganeti.TestHelper
  import Test.Ganeti.TestCommon
  import Test.Ganeti.TestHTools
  import Test.Ganeti.HTools.Instance ( genInstanceSmallerThanNode
                                     , genInstanceMaybeBiggerThanNode )
  import Test.Ganeti.HTools.Node (genOnlineNode, genNode)
  
  import Ganeti.BasicTypes
  import qualified Ganeti.HTools.AlgorithmParams as Alg
  import qualified Ganeti.HTools.Backend.IAlloc as IAlloc
  import qualified Ganeti.HTools.Cluster as Cluster
  import qualified Ganeti.HTools.Cluster.AllocationSolution as AllocSol
  import qualified Ganeti.HTools.Cluster.Evacuate as Evacuate
  import qualified Ganeti.HTools.Cluster.Metrics as Metrics
  import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils
  import qualified Ganeti.HTools.Container as Container
  import qualified Ganeti.HTools.Group as Group
  import qualified Ganeti.HTools.Instance as Instance
  import qualified Ganeti.HTools.Node as Node
  import qualified Ganeti.HTools.Types as Types
  import qualified Ganeti.Types as Types (EvacMode(..))
  
  {-# ANN module "HLint: ignore Use camelCase" #-}
  
  -- * Helpers
  
  -- | Make a small cluster, both nodes and instances.
  makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
                        -> (Node.List, Instance.List, Instance.Instance)
  makeSmallEmptyCluster node count inst =
    (makeSmallCluster node count, Container.empty,
     setInstanceSmallerThanNode node inst)
  
  -- | Checks if a node is "big" enough.
  isNodeBig :: Int -> Node.Node -> Bool
  isNodeBig size node = Node.availDisk node > size * Types.unitDsk
                        && Node.availMem node > size * Types.unitMem
                        && Node.availCpu node > size * Types.unitCpu
  
  canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
  canBalance tbl@(Cluster.Table _ _ ini_cv _)  dm im evac =
    maybe False (\(Cluster.Table _ _ fin_cv _) -> ini_cv - fin_cv > 1e-12)
    $ Cluster.tryBalance (Alg.defaultOptions { Alg.algMinGain = 0.0
                                             , Alg.algMinGainLimit = 0.0
                                             , Alg.algDiskMoves = dm
                                             , Alg.algInstanceMoves = im
                                             , Alg.algEvacMode = evac}) tbl
  
  -- | Assigns a new fresh instance to a cluster; this is not
  -- allocation, so no resource checks are done.
  assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
                    Types.Idx -> Types.Idx ->
                    (Node.List, Instance.List)
  assignInstance nl il inst pdx sdx =
    let pnode = Container.find pdx nl
        snode = Container.find sdx nl
        maxiidx = if Container.null il
                    then 0
                    else fst (Container.findMax il) + 1
        inst' = inst { Instance.idx = maxiidx,
                       Instance.pNode = pdx, Instance.sNode = sdx }
        pnode' = Node.setPri pnode inst'
        snode' = Node.setSec snode inst'
        nl' = Container.addTwo pdx pnode' sdx snode' nl
        il' = Container.add maxiidx inst' il
    in (nl', il')
  
  -- | Checks if an instance is mirrored.
  isMirrored :: Instance.Instance -> Bool
  isMirrored = (/= Types.MirrorNone) . Instance.mirrorType
  
  -- | Returns the possible change node types for a disk template.
  evacModeOptions :: Types.MirrorType -> [Types.EvacMode]
  evacModeOptions Types.MirrorNone     = []
  evacModeOptions Types.MirrorInternal = [minBound..maxBound] -- DRBD can do all
  evacModeOptions Types.MirrorExternal = [Types.ChangePrimary, Types.ChangeAll]
  
  -- * Test cases
  
  -- | Check that the cluster score is close to zero for a homogeneous
  -- cluster.
  prop_Score_Zero :: Node.Node -> Property
  prop_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) &&
       (Node.tSpindles node > 0) && (Node.tCpu node > 0)) ==>
    let fn = Node.buildPeers node Container.empty
        nlst = replicate count fn
        score = Metrics.compCVNodes nlst
    -- we can't say == 0 here as the floating point errors accumulate;
    -- this should be much lower than the default score in CLI.hs
    in score <= 1e-12
  
  -- | Check that cluster stats are sane.
  prop_CStats_sane :: Property
  prop_CStats_sane =
    forAll (choose (1, 1024)) $ \count ->
    forAll genOnlineNode $ \node ->
    let fn = Node.buildPeers node Container.empty
        nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
        nl = Container.fromList nlst
        cstats = Cluster.totalResources nl
    in Cluster.csAdsk cstats >= 0 &&
       Cluster.csAdsk cstats <= Cluster.csFdsk cstats
  
  -- | Check that one instance is allocated correctly on an empty cluster,
  -- without rebalances needed.
  prop_Alloc_sane :: Instance.Instance -> Property
  prop_Alloc_sane inst =
    forAll (choose (5, 20)) $ \count ->
    forAll genOnlineNode $ \node ->
    let (nl, il, inst') = makeSmallEmptyCluster node count inst
        reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
        opts = Alg.defaultOptions
    in case Cluster.genAllocNodes Alg.defaultOptions
                                  defGroupList nl reqnodes True >>=
       Cluster.tryAlloc opts nl il inst' of
         Bad msg -> failTest msg
         Ok as ->
           case AllocSol.asSolution as of
             Nothing -> failTest "Failed to allocate, empty solution"
             Just (xnl, xi, _, cv) ->
               let il' = Container.add (Instance.idx xi) xi il
                   tbl = Cluster.Table xnl il' cv []
               in counterexample "Cluster can be balanced after allocation"
                    (not (canBalance tbl True True False)) .&&.
                  counterexample "Solution score differs from actual node list"
                    (abs (Metrics.compCV xnl - cv) < 1e-12)
  
  -- | Checks that on a 2-5 node cluster, we can allocate a random
  -- 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_CanTieredAlloc :: Property
  prop_CanTieredAlloc =
    forAll (choose (2, 5)) $ \count ->
    forAll (liftM (Node.setPolicy Types.defIPolicy)
              (genOnlineNode `suchThat` isNodeBig 5)) $ \node ->
    forAll (genInstanceMaybeBiggerThanNode node) $ \inst ->
    let nl = makeSmallCluster node count
        il = Container.empty
        rqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
        allocnodes = Cluster.genAllocNodes Alg.defaultOptions
                                           defGroupList nl rqnodes True
        opts = Alg.defaultOptions
    in case allocnodes >>= \allocnodes' ->
      Cluster.tieredAlloc opts nl il (Just 5) inst allocnodes' [] [] of
         Bad msg -> failTest $ "Failed to tiered alloc: " ++ msg
         Ok (_, nl', il', ixes, cstats) ->
           let (ai_alloc, ai_pool, ai_unav) =
                 Cluster.computeAllocationDelta
                  (Cluster.totalResources nl)
                  (Cluster.totalResources nl')
               all_nodes fn = sum $ map fn (Container.elems nl)
               all_res fn = sum $ map fn [ai_alloc, ai_pool, ai_unav]
           in conjoin
              [ counterexample "No instances allocated" $ not (null ixes)
              , IntMap.size il' ==? length ixes
              , length ixes     ==? length cstats
              , all_res Types.allocInfoVCpus ==? all_nodes Node.hiCpu
              , all_res Types.allocInfoNCpus ==? all_nodes Node.tCpu
              , all_res Types.allocInfoMem   ==? truncate (all_nodes Node.tMem)
              , all_res Types.allocInfoDisk  ==? truncate (all_nodes Node.tDsk)
              ]
  
  -- | Helper function to create a cluster with the given range of nodes
  -- and allocate an instance on it.
  genClusterAlloc :: Int -> Node.Node -> Instance.Instance
                  -> Result (Node.List, Instance.List, Instance.Instance)
  genClusterAlloc count node inst =
    let nl = makeSmallCluster node count
        reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
        opts = Alg.defaultOptions
    in case Cluster.genAllocNodes Alg.defaultOptions
                                  defGroupList nl reqnodes True >>=
       Cluster.tryAlloc opts nl Container.empty inst of
         Bad msg -> Bad $ "Can't allocate: " ++ msg
         Ok as ->
           case AllocSol.asSolution as of
             Nothing -> Bad "Empty solution?"
             Just (xnl, xi, _, _) ->
               let xil = Container.add (Instance.idx xi) xi Container.empty
               in Ok (xnl, xil, xi)
  
  -- | Checks that on a 4-8 node cluster, once we allocate an instance,
  -- we can also relocate it.
  prop_AllocRelocate :: Property
  prop_AllocRelocate =
    forAll (choose (4, 8)) $ \count ->
    forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
    forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
    case genClusterAlloc count node inst of
      Bad msg -> failTest msg
      Ok (nl, il, inst') ->
        case IAlloc.processRelocate Alg.defaultOptions defGroupList nl il
               (Instance.idx inst) 1
               [(if Instance.diskTemplate inst' == Types.DTDrbd8
                   then Instance.sNode
                   else Instance.pNode) inst'] of
          Ok _ -> passTest
          Bad msg -> failTest $ "Failed to relocate: " ++ msg
  
  -- | Helper property checker for the result of a nodeEvac or
  -- changeGroup operation.
  check_EvacMode :: Group.Group -> Instance.Instance
                 -> Result (Node.List, Instance.List, Evacuate.EvacSolution)
                 -> Property
  check_EvacMode grp inst result =
    case result of
      Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
      Ok (_, _, es) ->
        let moved = Evacuate.esMoved es
            failed = Evacuate.esFailed es
            opcodes = not . null $ Evacuate.esOpCodes es
        in conjoin
             [ failmsg ("'failed' not empty: " ++ show failed) (null failed)
             , failmsg "'opcodes' is null" opcodes
             , case moved of
                 [(idx', gdx, _)] ->
                   failmsg "invalid instance moved" (idx == idx') .&&.
                   failmsg "wrong target group" (gdx == Group.idx grp)
                 v -> failmsg  ("invalid solution: " ++ show v) False
             ]
    where failmsg :: String -> Bool -> Property
          failmsg msg = counterexample ("Failed to evacuate: " ++ msg)
          idx = Instance.idx inst
  
  -- | Checks that on a 4-8 node cluster, once we allocate an instance,
  -- we can also node-evacuate it.
  prop_AllocEvacuate :: Property
  prop_AllocEvacuate =
    forAll (choose (4, 8)) $ \count ->
    forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
    forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
    case genClusterAlloc count node inst of
      Bad msg -> failTest msg
      Ok (nl, il, inst') ->
        conjoin . map (\mode -> check_EvacMode defGroup inst' $
                                Evacuate.tryNodeEvac Alg.defaultOptions
                                  defGroupList nl il mode
                                  [Instance.idx inst']) .
                                evacModeOptions .
                                Instance.mirrorType $ 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.
  prop_AllocChangeGroup :: Property
  prop_AllocChangeGroup =
    forAll (choose (4, 8)) $ \count ->
    forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
    forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
    case genClusterAlloc count node inst of
      Bad msg -> failTest msg
      Ok (nl, il, inst') ->
        -- we need to add a second node group and nodes to the cluster
        let nl2 = Container.elems $ makeSmallCluster node count
            grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
            maxndx = maximum . map Node.idx $ nl2
            nl3 = map (\n -> n { Node.group = Group.idx grp2
                               , Node.idx = Node.idx n + maxndx }) nl2
            nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
            gl' = Container.add (Group.idx grp2) grp2 defGroupList
            nl' = IntMap.union nl nl4
            opts = Alg.defaultOptions
        in check_EvacMode grp2 inst' $
           Cluster.tryChangeGroup opts gl' nl' il [] [Instance.idx inst']
  
  -- | Check that allocating multiple instances on a cluster, then
  -- adding an empty node, results in a valid rebalance.
  prop_AllocBalance :: Property
  prop_AllocBalance =
    forAll (genNode (Just 5) (Just 128)) $ \node ->
    forAll (choose (3, 5)) $ \count ->
    not (Node.offline node) && not (Node.failN1 node) ==>
    let nl = makeSmallCluster node count
        hnode = snd $ IntMap.findMax nl
        nl' = IntMap.deleteMax nl
        il = Container.empty
        allocnodes = Cluster.genAllocNodes Alg.defaultOptions
                                           defGroupList nl' 2 True
        i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
        opts = Alg.defaultOptions
    in case allocnodes >>= \allocnodes' ->
      Cluster.iterateAlloc opts nl' il (Just 5) i_templ allocnodes' [] [] of
         Bad msg -> failTest $ "Failed to allocate: " ++ msg
         Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
         Ok (_, xnl, il', _, _) ->
           let ynl = Container.add (Node.idx hnode) hnode xnl
               cv = Metrics.compCV ynl
               tbl = Cluster.Table ynl il' cv []
           in counterexample "Failed to rebalance" $
              canBalance tbl True True False
  
  -- | Checks consistency.
  prop_CheckConsistency :: Node.Node -> Instance.Instance -> Bool
  prop_CheckConsistency node inst =
    let nl = makeSmallCluster node 3
        (node1, node2, node3) =
          case Container.elems nl of
            [a, b, c] -> (a, b, c)
            l -> error $ "Invalid node list out of makeSmallCluster/3: " ++
                 show l
        node3' = node3 { Node.group = 1 }
        nl' = Container.add (Node.idx node3') node3' nl
        inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
        inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
        inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
        ccheck = Cluster.findSplitInstances nl' . Container.fromList
    in null (ccheck [(0, inst1)]) &&
       null (ccheck [(0, inst2)]) &&
       (not . null $ ccheck [(0, inst3)])
  
  -- | For now, we only test that we don't lose instances during the split.
  prop_SplitCluster :: Node.Node -> Instance.Instance -> Property
  prop_SplitCluster node inst =
    forAll (choose (0, 100)) $ \icnt ->
    let nl = makeSmallCluster node 2
        (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
                     (nl, Container.empty) [1..icnt]
        gni = ClusterUtils.splitCluster nl' il'
    in sum (map (Container.size . snd . snd) gni) == icnt &&
       all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
                                   (Container.elems nl'')) gni
  
  -- | Helper function to check if we can allocate an instance on a
  -- given node list. Successful allocation is denoted by 'Nothing',
  -- otherwise the 'Just' value will contain the error message.
  canAllocOn :: Node.List -> Int -> Instance.Instance -> Maybe String
  canAllocOn nl reqnodes inst =
    case Cluster.genAllocNodes Alg.defaultOptions
                               defGroupList nl reqnodes True >>=
         Cluster.tryAlloc Alg.defaultOptions nl Container.empty inst of
         Bad msg -> Just $ "Can't allocate: " ++ msg
         Ok as ->
           case AllocSol.asSolution as of
             Nothing -> Just $ "No allocation solution; failures: " ++
                        show (AllocSol.collapseFailures $ AllocSol.asFailures as)
             Just _ -> Nothing
  
  -- | Checks that allocation obeys minimum and maximum instance
  -- policies. The unittest generates a random node, duplicates it /count/
  -- 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_AllocPolicy :: Property
  prop_AllocPolicy =
    forAll genOnlineNode $ \node ->
    forAll (choose (5, 20)) $ \count ->
    forAll (genInstanceSmallerThanNode node) $ \inst ->
    forAll (arbitrary `suchThat`
            (isBad . flip (Instance.instMatchesPolicy inst)
             (Node.exclStorage node))) $ \ipol ->
    let rqn = Instance.requiredNodes $ Instance.diskTemplate inst
        node' = Node.setPolicy ipol node
        nl = makeSmallCluster node' count
    in counterexample "Allocation check:"
         (isNothing (canAllocOn (makeSmallCluster node count) rqn inst)) .&&.
       counterexample "Policy failure check:" (isJust $ canAllocOn nl rqn inst)
  
  testSuite "HTools/Cluster"
              [ 'prop_Score_Zero
              , 'prop_CStats_sane
              , 'prop_Alloc_sane
              , 'prop_CanTieredAlloc
              , 'prop_AllocRelocate
              , 'prop_AllocEvacuate
              , 'prop_AllocChangeGroup
              , 'prop_AllocBalance
              , 'prop_CheckConsistency
              , 'prop_SplitCluster
              , 'prop_AllocPolicy
              ]
  