AllocElement: extend with the cluster score

[ganeti-local] / Ganeti / HTools / Cluster.hs

diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index f5a956b..c52093d 100644 (file)
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -61,6 +61,9 @@ module Ganeti.HTools.Cluster
     -- * Allocation functions
     , iterateAlloc
     , tieredAlloc
+    , instanceGroup
+    , findSplitInstances
+    , splitCluster
     ) where
 
 import Data.List
@@ -384,9 +387,10 @@ allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
 allocateOnSingle nl inst p =
     let new_pdx = Node.idx p
         new_inst = Instance.setBoth inst new_pdx Node.noSecondary
-        new_nl = Node.addPri p inst >>= \new_p ->
-                 return (Container.add new_pdx new_p nl, new_inst, [new_p])
-    in new_nl
+    in  Node.addPri p inst >>= \new_p -> do
+      let new_nl = Container.add new_pdx new_p nl
+          new_score = compCV nl
+      return (new_nl, new_inst, [new_p], new_score)
 
 -- | Tries to allocate an instance on a given pair of nodes.
 allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
@@ -394,13 +398,12 @@ allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
 allocateOnPair nl inst tgt_p tgt_s =
     let new_pdx = Node.idx tgt_p
         new_sdx = Node.idx tgt_s
-        new_nl = do -- Maybe monad
-          new_p <- Node.addPri tgt_p inst
-          new_s <- Node.addSec tgt_s inst new_pdx
-          let new_inst = Instance.setBoth inst new_pdx new_sdx
-          return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
-                 [new_p, new_s])
-    in new_nl
+    in do
+      new_p <- Node.addPri tgt_p inst
+      new_s <- Node.addSec tgt_s inst new_pdx
+      let new_inst = Instance.setBoth inst new_pdx new_sdx
+          new_nl = Container.addTwo new_pdx new_p new_sdx new_s nl
+      return (new_nl, new_inst, [new_p, new_s], compCV new_nl)
 
 -- | Tries to perform an instance move and returns the best table
 -- between the original one and the new one.
@@ -532,9 +535,8 @@ collapseFailures flst =
 concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
 concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
 
-concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
-    let nscore = compCV nl
-        -- Choose the old or new solution, based on the cluster score
+concatAllocs (flst, cntok, osols) (OpGood ns@(_, _, _, nscore)) =
+    let -- Choose the old or new solution, based on the cluster score
         nsols = case osols of
                   [] -> [(nscore, ns)]
                   (oscore, _):[] ->
@@ -598,7 +600,8 @@ tryReloc nl il xid 1 ex_idx =
                             let em = do
                                   (mnl, i, _, _) <-
                                       applyMove nl inst (ReplaceSecondary x)
-                                  return (mnl, i, [Container.find x mnl])
+                                  return (mnl, i, [Container.find x mnl],
+                                          compCV mnl)
                             in concatAllocs cstate em
                        ) ([], 0, []) valid_idxes
     in return sols1
@@ -621,7 +624,7 @@ tryEvac nl il ex_ndx =
                            -- FIXME: hardcoded one node here
                            (fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
                            case aes of
-                             csol@(_, (nl'', _, _)):_ ->
+                             csol@(_, (nl'', _, _, _)):_ ->
                                  return (nl'', (fm, cs, csol:rsols))
                              _ -> fail $ "Can't evacuate instance " ++
                                   Instance.name (Container.find idx il)
@@ -646,7 +649,7 @@ iterateAlloc nl il newinst nreq ixes =
            Ok (errs, _, sols3) ->
                case sols3 of
                  [] -> Ok (collapseFailures errs, nl, il, ixes)
-                 (_, (xnl, xi, _)):[] ->
+                 (_, (xnl, xi, _, _)):[] ->
                      iterateAlloc xnl (Container.add newidx xi il)
                                   newinst nreq $! (xi:ixes)
                  _ -> Bad "Internal error: multiple solutions for single\
@@ -830,3 +833,35 @@ iMoveToJob nl il idx move =
          ReplaceSecondary ns -> [ opR ns ]
          ReplaceAndFailover np -> [ opR np, opF ]
          FailoverAndReplace ns -> [ opF, opR ns ]
+
+-- | Computes the group of an instance
+instanceGroup :: Node.List -> Instance.Instance -> Result GroupID
+instanceGroup nl i =
+  let sidx = Instance.sNode i
+      pnode = Container.find (Instance.pNode i) nl
+      snode = if sidx == Node.noSecondary
+              then pnode
+              else Container.find sidx nl
+      puuid = Node.group pnode
+      suuid = Node.group snode
+  in if puuid /= suuid
+     then fail ("Instance placed accross two node groups, primary " ++ puuid ++
+                ", secondary " ++ suuid)
+     else return puuid
+
+-- | Compute the list of badly allocated instances (split across node
+-- groups)
+findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
+findSplitInstances nl il =
+  filter (not . isOk . instanceGroup nl) (Container.elems il)
+
+-- | Splits a cluster into the component node groups
+splitCluster :: Node.List -> Instance.List ->
+                [(GroupID, (Node.List, Instance.List))]
+splitCluster nl il =
+  let ngroups = Node.computeGroups (Container.elems nl)
+  in map (\(guuid, nodes) ->
+           let nidxs = map Node.idx nodes
+               nodes' = zip nidxs nodes
+               instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
+           in (guuid, (Container.fromAssocList nodes', instances))) ngroups