diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index 8ba4edc4008525daff3588fbf0bc9e1438827a33..09b281459b77e7fe8d9f6ccd7e951fa90b76a708 100644
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -29,7 +29,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.HTools.Cluster
(
-- * Types
- AllocSolution
+ AllocSolution(..)
, Table(..)
, CStats(..)
, AllocStats
@@ -81,7 +81,19 @@ import qualified Ganeti.OpCodes as OpCodes
-- * Types
-- | Allocation\/relocation solution.
-type AllocSolution = ([FailMode], Int, [Node.AllocElement])
+data AllocSolution = AllocSolution
+ { asFailures :: [FailMode] -- ^ Failure counts
+ , asAllocs :: Int -- ^ Good allocation count
+ , asSolutions :: [Node.AllocElement] -- ^ The actual result, length
+ -- of the list depends on the
+ -- allocation/relocation mode
+
+ }
+
+-- | The empty solution we start with when computing allocations
+emptySolution :: AllocSolution
+emptySolution = AllocSolution { asFailures = [], asAllocs = 0
+ , asSolutions = [] }
-- | The complete state for the balancing solution
data Table = Table Node.List Instance.List Score [Placement]
@@ -533,10 +545,12 @@ collapseFailures flst =
-- | Update current Allocation solution and failure stats with new
-- elements
concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
-concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
+concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
-concatAllocs (flst, cntok, osols) (OpGood ns@(_, _, _, nscore)) =
+concatAllocs as (OpGood ns@(_, _, _, nscore)) =
let -- Choose the old or new solution, based on the cluster score
+ cntok = asAllocs as
+ osols = asSolutions as
nsols = case osols of
[] -> [ns]
(_, _, _, oscore):[] ->
@@ -553,7 +567,7 @@ concatAllocs (flst, cntok, osols) (OpGood ns@(_, _, _, nscore)) =
-- in the next cycle, so we force evaluation of nsols, since the
-- foldl' in the caller will only evaluate the tuple, but not the
-- elements of the tuple
- in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
+ in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolutions = nsols }
-- | Try to allocate an instance on the cluster.
tryAlloc :: (Monad m) =>
@@ -568,14 +582,14 @@ tryAlloc nl _ inst 2 =
ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
sols = foldl' (\cstate (p, s) ->
concatAllocs cstate $ allocateOnPair nl inst p s
- ) ([], 0, []) ok_pairs
+ ) emptySolution ok_pairs
in return sols
tryAlloc nl _ inst 1 =
let all_nodes = getOnline nl
sols = foldl' (\cstate ->
concatAllocs cstate . allocateOnSingle nl inst
- ) ([], 0, []) all_nodes
+ ) emptySolution all_nodes
in return sols
tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
@@ -603,7 +617,7 @@ tryReloc nl il xid 1 ex_idx =
return (mnl, i, [Container.find x mnl],
compCV mnl)
in concatAllocs cstate em
- ) ([], 0, []) valid_idxes
+ ) emptySolution valid_idxes
in return sols1
tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
@@ -620,15 +634,23 @@ tryEvac nl il ex_ndx =
let ex_nodes = map (`Container.find` nl) ex_ndx
all_insts = nub . concatMap Node.sList $ ex_nodes
in do
- (_, sol) <- foldM (\(nl', (_, _, rsols)) idx -> do
- -- FIXME: hardcoded one node here
- (fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
- case aes of
- csol@(nl'', _, _, _):_ ->
- return (nl'', (fm, cs, csol:rsols))
- _ -> fail $ "Can't evacuate instance " ++
- Instance.name (Container.find idx il)
- ) (nl, ([], 0, [])) all_insts
+ (_, sol) <- foldM (\(nl', old_as) idx -> do
+ -- FIXME: hardcoded one node here
+ -- (fm, cs, aes)
+ new_as <- tryReloc nl' il idx 1 ex_ndx
+ case asSolutions new_as of
+ csol@(nl'', _, _, _):_ ->
+ -- an individual relocation succeeded,
+ -- we kind of compose the data from
+ -- the two solutions
+ return (nl'',
+ new_as { asSolutions =
+ csol:asSolutions old_as })
+ -- this relocation failed, so we fail
+ -- the entire evac
+ _ -> fail $ "Can't evacuate instance " ++
+ Instance.name (Container.find idx il)
+ ) (nl, emptySolution) all_insts
return sol
-- | Recursively place instances on the cluster until we're out of space
@@ -646,7 +668,7 @@ iterateAlloc nl il newinst nreq ixes =
newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
in case tryAlloc nl il newi2 nreq of
Bad s -> Bad s
- Ok (errs, _, sols3) ->
+ Ok (AllocSolution { asFailures = errs, asSolutions = sols3 }) ->
case sols3 of
[] -> Ok (collapseFailures errs, nl, il, ixes)
(xnl, xi, _, _):[] ->
diff --git a/Ganeti/HTools/QC.hs b/Ganeti/HTools/QC.hs
index 9f471cedbdbcfb400af08f5c226e49464a760d6a..ebcc93970d55762220a4aaeda778feba033211ef 100644
--- a/Ganeti/HTools/QC.hs
+++ b/Ganeti/HTools/QC.hs
@@ -673,8 +673,8 @@ prop_ClusterAlloc_sane node inst =
inst' = setInstanceSmallerThanNode node inst
in case Cluster.tryAlloc nl il inst' rqnodes of
Types.Bad _ -> False
- Types.Ok (_, _, sols3) ->
- case sols3 of
+ Types.Ok as ->
+ case Cluster.asSolutions as of
[] -> False
(xnl, xi, _, cv):[] ->
let il' = Container.add (Instance.idx xi) xi il
@@ -713,8 +713,8 @@ prop_ClusterAllocEvac node inst =
inst' = setInstanceSmallerThanNode node inst
in case Cluster.tryAlloc nl il inst' rqnodes of
Types.Bad _ -> False
- Types.Ok (_, _, sols3) ->
- case sols3 of
+ Types.Ok as ->
+ case Cluster.asSolutions as of
[] -> False
(xnl, xi, _, _):[] ->
let sdx = Instance.sNode xi
diff --git a/hail.hs b/hail.hs
index 90902e679e2e1108db1a0922b90fa7f329aec971..e007504ed1ca1415792a20e4858ac2720af705bd 100644
--- a/hail.hs
+++ b/hail.hs
@@ -49,21 +49,24 @@ options = [oPrintNodes, oShowVer, oShowHelp]
processResults :: (Monad m) =>
RqType -> Cluster.AllocSolution
-> m (String, Cluster.AllocSolution)
-processResults _ (_, _, []) = fail "No valid allocation solutions"
-processResults (Evacuate _) as@(fstats, successes, sols) =
- let (_, _, _, best) = head sols
+processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [] }) =
+ fail "No valid allocation solutions"
+processResults (Evacuate _) as =
+ let fstats = Cluster.asFailures as
+ successes = Cluster.asAllocs as
+ (_, _, _, best) = head (Cluster.asSolutions as)
tfails = length fstats
info = printf "for last allocation, successes %d, failures %d,\
\ best score: %.8f" successes tfails best::String
in return (info, as)
-processResults _ as@(fstats, successes, sols) =
- case sols of
+processResults _ as =
+ case Cluster.asSolutions as of
(_, _, w, best):[] ->
- let tfails = length fstats
+ let tfails = length (Cluster.asFailures as)
info = printf "successes %d, failures %d,\
\ best score: %.8f for node(s) %s"
- successes tfails
+ (Cluster.asAllocs as) tfails
best (intercalate "/" . map Node.name $ w)::String
in return (info, as)
_ -> fail "Internal error: multiple allocation solutions"
@@ -107,8 +110,8 @@ main = do
let sols = processRequest request >>= processResults rq
let (ok, info, rn) =
case sols of
- Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
- sn)
+ Ok (ginfo, as) -> (True, "Request successful: " ++ ginfo,
+ Cluster.asSolutions as)
Bad s -> (False, "Request failed: " ++ s, [])
resp = formatResponse ok info rq rn
putStrLn resp