diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index 7172cff076ea51b43fba8a60394a4af67c043a32..c52093d256d999bfe5ff6fb2b9861420707f0cdd 100644
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -387,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
@@ -397,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.
@@ -535,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, _):[] ->
@@ -601,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
@@ -624,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)
@@ -649,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\
diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index d0bfec69539d56df222012f5a496d20ab82c0871..c60e36185ff3a18082554103d5e557ae1d7cb2fc 100644
--- a/Ganeti/HTools/IAlloc.hs
+++ b/Ganeti/HTools/IAlloc.hs
@@ -4,7 +4,7 @@
{-
-Copyright (C) 2009 Google Inc.
+Copyright (C) 2009, 2010 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -147,13 +147,13 @@ formatRVal :: RqType -> [Node.AllocElement] -> JSValue
formatRVal _ [] = JSArray []
formatRVal (Evacuate _) elems =
- let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl)
+ let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
elems
jsols = map (JSArray . map (JSString . toJSString)) sols
in JSArray jsols
formatRVal _ elems =
- let (_, _, nodes) = head elems
+ let (_, _, nodes, _) = head elems
nodes' = map Node.name nodes
in JSArray $ map (JSString . toJSString) nodes'
diff --git a/Ganeti/HTools/Node.hs b/Ganeti/HTools/Node.hs
index 2740d18cefa65db06725cb3709a5da6ad6be426b..5fd331d7b0650c7ee8c38fb9d2567316fc6762b6 100644
--- a/Ganeti/HTools/Node.hs
+++ b/Ganeti/HTools/Node.hs
@@ -139,7 +139,7 @@ type List = Container.Container Node
-- | A simple name for an allocation element (here just for logistic
-- reasons)
-type AllocElement = (List, Instance.Instance, [Node])
+type AllocElement = (List, Instance.Instance, [Node], T.Score)
-- | Constant node index for a non-moveable instance.
noSecondary :: T.Ndx
diff --git a/Ganeti/HTools/QC.hs b/Ganeti/HTools/QC.hs
index 206d86ed17c4eed2af16ba686ac2af12be9085e7..f411a8e62a8888c1e3129708e0e4449c97cd685d 100644
--- a/Ganeti/HTools/QC.hs
+++ b/Ganeti/HTools/QC.hs
@@ -676,9 +676,8 @@ prop_ClusterAlloc_sane node inst =
Types.Ok (_, _, sols3) ->
case sols3 of
[] -> False
- (_, (xnl, xi, _)):[] ->
- let cv = Cluster.compCV xnl
- il' = Container.add (Instance.idx xi) xi il
+ (_, (xnl, xi, _, cv)):[] ->
+ let il' = Container.add (Instance.idx xi) xi il
tbl = Cluster.Table xnl il' cv []
in not (canBalance tbl True False)
_ -> False
@@ -717,7 +716,7 @@ prop_ClusterAllocEvac node inst =
Types.Ok (_, _, sols3) ->
case sols3 of
[] -> False
- (_, (xnl, xi, _)):[] ->
+ (_, (xnl, xi, _, _)):[] ->
let sdx = Instance.sNode xi
il' = Container.add (Instance.idx xi) xi il
in case Cluster.tryEvac xnl il' [sdx] of
diff --git a/hail.hs b/hail.hs
index d67bd68394d66e749b853fb0a607f53b4631ab95..2f00da25057783917713d6151eae91da40ab179b 100644
--- a/hail.hs
+++ b/hail.hs
@@ -59,7 +59,7 @@ processResults (Evacuate _) as@(fstats, successes, sols) =
processResults _ as@(fstats, successes, sols) =
case sols of
- (best, (_, _, w)):[] ->
+ (best, (_, _, w, _)):[] ->
let tfails = length fstats
info = printf "successes %d, failures %d,\
\ best score: %.8f for node(s) %s"