{-# 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
            ]