commit 3fea6959e954e6f035fd002bc4ff883bd3ab26cd
Author: Iustin Pop <iustin@google.com>
Date:   Thu May 20 18:36:26 2010 +0200

    Add more unit tests for allocation/balance
    
    The patch adds some simple unit-tests for both the allocation function
    (we can allocate small instances on an empty cluster, we can allocate in
    tiered more starting from any size) and the balancing functions (one
    single instance is placed optimally, a full cluster plus an empty node
    can be rebalanced). The coverage has increased greatly, since this is
    the bulk of the algorithm/code.
    
    Also, the cluster tests are now being run with different options, since
    they are much slower.

diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index 614b250..6548d48 100644
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -476,18 +476,16 @@ checkMove nodes_idx disk_moves ini_tbl victims =
        else best_tbl
 
 -- | Check if we are allowed to go deeper in the balancing
-
-doNextBalance :: Table       -- ^ The starting table
-              -> Int         -- ^ Remaining length
-              -> Score       -- ^ Score at which to stop
-              -> Bool -- ^ The resulting table and commands
+doNextBalance :: Table     -- ^ The starting table
+              -> Int       -- ^ Remaining length
+              -> Score     -- ^ Score at which to stop
+              -> Bool      -- ^ The resulting table and commands
 doNextBalance ini_tbl max_rounds min_score =
     let Table _ _ ini_cv ini_plc = ini_tbl
         ini_plc_len = length ini_plc
     in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
 
 -- | Run a balance move
-
 tryBalance :: Table       -- ^ The starting table
            -> Bool        -- ^ Allow disk moves
            -> Bool        -- ^ Only evacuate moves
@@ -599,7 +597,7 @@ tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
                                 \destinations required (" ++ show reqn ++
                                                   "), only one supported"
 
--- | Try to allocate an instance on the cluster.
+-- | Try to evacuate a list of nodes.
 tryEvac :: (Monad m) =>
             Node.List       -- ^ The node list
          -> Instance.List   -- ^ The instance list
diff --git a/Ganeti/HTools/QC.hs b/Ganeti/HTools/QC.hs
index 6c7f4ce..3dd086b 100644
--- a/Ganeti/HTools/QC.hs
+++ b/Ganeti/HTools/QC.hs
@@ -36,6 +36,7 @@ import Test.QuickCheck
 import Test.QuickCheck.Batch
 import Data.Maybe
 import qualified Data.Map
+import qualified Data.IntMap as IntMap
 import qualified Ganeti.HTools.CLI as CLI
 import qualified Ganeti.HTools.Cluster as Cluster
 import qualified Ganeti.HTools.Container as Container
@@ -48,6 +49,8 @@ import qualified Ganeti.HTools.Text as Text
 import qualified Ganeti.HTools.Types as Types
 import qualified Ganeti.HTools.Utils as Utils
 
+-- * Constants
+
 -- | Maximum memory (1TiB, somewhat random value)
 maxMem :: Int
 maxMem = 1024 * 1024
@@ -60,6 +63,8 @@ maxDsk = 1024 * 1024 * 8
 maxCpu :: Int
 maxCpu = 1024
 
+-- * Helper functions
+
 -- | Simple checker for whether OpResult is fail or pass
 isFailure :: Types.OpResult a -> Bool
 isFailure (Types.OpFail _) = True
@@ -70,6 +75,36 @@ isOk :: Types.Result a -> Bool
 isOk (Types.Ok _ ) = True
 isOk _ = 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
+         , Instance.vcpus = (Node.availCpu node) `div` 2
+         }
+
+-- | Create an instance given its spec
+createInstance mem dsk vcpus =
+    Instance.create "inst-unnamed" mem dsk vcpus "running" [] (-1) (-1)
+
+-- | Create a small cluster by repeating a node spec
+makeSmallCluster :: Node.Node -> Int -> Node.List
+makeSmallCluster node count =
+    let fn = Node.buildPeers node Container.empty
+        namelst = map (\n -> (Node.name n, n)) (replicate count fn)
+        (_, nlst) = Loader.assignIndices namelst
+    in Container.fromAssocList nlst
+
+-- | Checks if a node is "big" enough
+isNodeBig :: Node.Node -> Int -> Bool
+isNodeBig node size = Node.availDisk node > size * Types.unitDsk
+                      && Node.availMem node > size * Types.unitMem
+                      && Node.availCpu node > size * Types.unitCpu
+
+canBalance :: Cluster.Table -> Bool -> Bool -> Bool
+canBalance tbl dm evac = isJust $ Cluster.tryBalance tbl dm evac
+
+-- * Arbitrary instances
+
 -- copied from the introduction to quickcheck
 instance Arbitrary Char where
     arbitrary = choose ('\32', '\128')
@@ -105,11 +140,7 @@ instance Arbitrary Node.Node where
           n' = Node.buildPeers n Container.empty
       return n'
 
-setInstanceSmallerThanNode node inst =
-    inst { Instance.mem = (Node.availMem node) `div` 2
-         , Instance.dsk = (Node.availDisk node) `div` 2
-         , Instance.vcpus = (Node.availCpu node) `div` 2
-         }
+-- * Actual tests
 
 -- | Make sure add is idempotent
 prop_PeerMap_addIdempotent pmap key em =
@@ -394,7 +425,7 @@ prop_Score_Zero node count =
 -- | Check that cluster stats are sane
 prop_CStats_sane node count =
     (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
-     (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
+     (Node.availDisk node > 0) && (Node.availMem node > 0)) ==>
     let fn = Node.buildPeers node Container.empty
         nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
         nl = Container.fromAssocList nlst
@@ -402,7 +433,102 @@ prop_CStats_sane node count =
     in Cluster.csAdsk cstats >= 0 &&
        Cluster.csAdsk cstats <= Cluster.csFdsk cstats
 
+-- | Check that one instance is allocated correctly, without
+-- rebalances needed
+prop_ClusterAlloc_sane node inst =
+    forAll (choose (5, 20)) $ \count ->
+    not (Node.offline node)
+            && not (Node.failN1 node)
+            && Node.availDisk node > 0
+            && Node.availMem node > 0
+            ==>
+    let nl = makeSmallCluster node count
+        il = Container.empty
+        rqnodes = 2
+        inst' = setInstanceSmallerThanNode node inst
+    in case Cluster.tryAlloc nl il inst' rqnodes of
+         Types.Bad _ -> False
+         Types.Ok (errs, _, sols3) ->
+             case sols3 of
+               [] -> False
+               (_, (xnl, xi, _)):[] ->
+                   let cv = Cluster.compCV xnl
+                       il' = Container.add (Instance.idx xi) xi il
+                       tbl = Cluster.Table xnl il' cv []
+                   in not (canBalance tbl True False)
+               _ -> False
+
+-- | 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
+prop_ClusterCanTieredAlloc node inst =
+    forAll (choose (2, 5)) $ \count ->
+    forAll (choose (1, 2)) $ \rqnodes ->
+    not (Node.offline node)
+            && not (Node.failN1 node)
+            && isNodeBig node 4
+            ==>
+    let nl = makeSmallCluster node count
+        il = Container.empty
+    in case Cluster.tieredAlloc nl il inst rqnodes [] of
+         Types.Bad _ -> False
+         Types.Ok (_, _, ixes) -> not (null ixes)
+
+-- | Checks that on a 4-8 node cluster, once we allocate an instance,
+-- we can also evacuate it
+prop_ClusterAllocEvac node inst =
+    forAll (choose (4, 8)) $ \count ->
+    not (Node.offline node)
+            && not (Node.failN1 node)
+            && isNodeBig node 4
+            ==>
+    let nl = makeSmallCluster node count
+        il = Container.empty
+        rqnodes = 2
+        inst' = setInstanceSmallerThanNode node inst
+    in case Cluster.tryAlloc nl il inst' rqnodes of
+         Types.Bad _ -> False
+         Types.Ok (errs, _, sols3) ->
+             case sols3 of
+               [] -> False
+               (_, (xnl, xi, _)):[] ->
+                   let sdx = Instance.sNode xi
+                       il' = Container.add (Instance.idx xi) xi il
+                   in case Cluster.tryEvac xnl il' [sdx] of
+                        Just _ -> True
+                        _ -> False
+               _ -> False
+
+-- | Check that allocating multiple instances on a cluster, then
+-- adding an empty node, results in a valid rebalance
+prop_ClusterAllocBalance node =
+    forAll (choose (3, 5)) $ \count ->
+    not (Node.offline node)
+            && not (Node.failN1 node)
+            && isNodeBig node 4
+            && not (isNodeBig node 8)
+            ==>
+    let nl = makeSmallCluster node count
+        (hnode, nl') = IntMap.deleteFindMax nl
+        il = Container.empty
+        rqnodes = 2
+        i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
+    in case Cluster.iterateAlloc nl' il i_templ rqnodes [] of
+         Types.Bad _ -> False
+         Types.Ok (_, xnl, insts) ->
+                   let ynl = Container.add (Node.idx hnode) hnode xnl
+                       cv = Cluster.compCV ynl
+                       il' = foldl (\l i ->
+                                        Container.add (Instance.idx i) i l)
+                             il insts
+                       tbl = Cluster.Table ynl il' cv []
+                   in canBalance tbl True False
+
 testCluster =
     [ run prop_Score_Zero
     , run prop_CStats_sane
+    , run prop_ClusterAlloc_sane
+    , run prop_ClusterCanTieredAlloc
+    , run prop_ClusterAllocEvac
+    , run prop_ClusterAllocBalance
     ]
diff --git a/test.hs b/test.hs
index 8fffa99..8caf619 100644
--- a/test.hs
+++ b/test.hs
@@ -25,7 +25,6 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 
 module Main(main) where
 
-import Control.Monad
 import Data.IORef
 import Test.QuickCheck.Batch
 import System.IO
@@ -33,12 +32,17 @@ import System.Exit
 
 import Ganeti.HTools.QC
 
-options :: TestOptions
-options = TestOptions
-      { no_of_tests         = 500
-      , length_of_tests     = 10
-      , debug_tests         = False }
+fastOptions :: TestOptions
+fastOptions = TestOptions
+              { no_of_tests         = 500
+              , length_of_tests     = 10
+              , debug_tests         = False }
 
+slowOptions :: TestOptions
+slowOptions = TestOptions
+              { no_of_tests         = 50
+              , length_of_tests     = 100
+              , debug_tests         = False }
 
 incIORef :: IORef Int -> IO ()
 incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ()))
@@ -59,12 +63,12 @@ main :: IO ()
 main = do
   errs <- newIORef 0
   let wrap = map (wrapTest errs)
-  runTests "PeerMap" options $ wrap testPeerMap
-  runTests "Container" options $ wrap testContainer
-  runTests "Instance" options $ wrap testInstance
-  runTests "Node" options $ wrap testNode
-  runTests "Text" options $ wrap testText
-  runTests "Cluster" options $ wrap testCluster
+  runTests "PeerMap" fastOptions $ wrap testPeerMap
+  runTests "Container" fastOptions $ wrap testContainer
+  runTests "Instance" fastOptions $ wrap testInstance
+  runTests "Node" fastOptions $ wrap testNode
+  runTests "Text" fastOptions $ wrap testText
+  runTests "Cluster" slowOptions $ wrap testCluster
   terr <- readIORef errs
   (if terr > 0
    then do
