From 129734d3dde61ea2b967f5178e2de4f3789409b4 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Fri, 23 Sep 2011 13:23:29 +0900
Subject: [PATCH] Change type of Cluster.AllocSolution
Originally, this data type was used both by instance allocation (1
result), and by instance relocation (many results, one per
instance). As such, the field 'asSolutions' was a list, and the
various code paths checked whether the length of the list matches the
current mode. This is very ugly, as we can't guarantee this matching
via the type system; hence the FIXME in the code.
However, commit 6804faa removed the instance evacuation code, and thus
we now always use just one allocation solution. Hence we can change
the data type to a simply Maybe type, and get rid of many 'otherwise
barf out' conditions.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>
---
htools/Ganeti/HTools/Cluster.hs | 58 ++++++++++++++-------------------
htools/Ganeti/HTools/IAlloc.hs | 7 ++--
htools/Ganeti/HTools/QC.hs | 14 ++++----
3 files changed, 33 insertions(+), 46 deletions(-)
diff --git a/htools/Ganeti/HTools/Cluster.hs b/htools/Ganeti/HTools/Cluster.hs
index 3d1b9f23f..bb00ce141 100644
--- a/htools/Ganeti/HTools/Cluster.hs
+++ b/htools/Ganeti/HTools/Cluster.hs
@@ -75,7 +75,7 @@ module Ganeti.HTools.Cluster
import qualified Data.IntSet as IntSet
import Data.List
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isNothing)
import Data.Ord (comparing)
import Text.Printf (printf)
import Control.Monad
@@ -93,12 +93,10 @@ import qualified Ganeti.OpCodes as OpCodes
-- | Allocation\/relocation solution.
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
- , asLog :: [String] -- ^ A list of informational messages
+ { asFailures :: [FailMode] -- ^ Failure counts
+ , asAllocs :: Int -- ^ Good allocation count
+ , asSolution :: Maybe Node.AllocElement -- ^ The actual allocation result
+ , asLog :: [String] -- ^ Informational messages
}
-- | Node evacuation/group change iallocator result type. This result
@@ -125,7 +123,7 @@ type AllocNodes = Either [Ndx] [(Ndx, Ndx)]
-- | The empty solution we start with when computing allocations.
emptyAllocSolution :: AllocSolution
emptyAllocSolution = AllocSolution { asFailures = [], asAllocs = 0
- , asSolutions = [], asLog = [] }
+ , asSolution = Nothing, asLog = [] }
-- | The empty evac solution.
emptyEvacSolution :: EvacSolution
@@ -610,42 +608,36 @@ concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
concatAllocs as (OpGood ns@(_, _, _, nscore)) =
let -- Choose the old or new solution, based on the cluster score
cntok = asAllocs as
- osols = asSolutions as
+ osols = asSolution as
nsols = case osols of
- [] -> [ns]
- (_, _, _, oscore):[] ->
+ Nothing -> Just ns
+ Just (_, _, _, oscore) ->
if oscore < nscore
then osols
- else [ns]
- -- FIXME: here we simply concat to lists with more
- -- than one element; we should instead abort, since
- -- this is not a valid usage of this function
- xs -> ns:xs
+ else Just ns
nsuc = cntok + 1
-- Note: we force evaluation of nsols here in order to keep the
-- memory profile low - we know that we will need nsols for sure
-- 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` as { asAllocs = nsuc, asSolutions = nsols }
+ in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolution = nsols }
-- | Given a solution, generates a reasonable description for it.
describeSolution :: AllocSolution -> String
describeSolution as =
let fcnt = asFailures as
- sols = asSolutions as
+ sols = asSolution as
freasons =
intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
filter ((> 0) . snd) . collapseFailures $ fcnt
- in if null sols
- then "No valid allocation solutions, failure reasons: " ++
- (if null fcnt
- then "unknown reasons"
- else freasons)
- else let (_, _, nodes, cv) = head sols
- in printf ("score: %.8f, successes %d, failures %d (%s)" ++
- " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
- (intercalate "/" . map Node.name $ nodes)
+ in case sols of
+ Nothing -> "No valid allocation solutions, failure reasons: " ++
+ (if null fcnt then "unknown reasons" else freasons)
+ Just (_, _, nodes, cv) ->
+ printf ("score: %.8f, successes %d, failures %d (%s)" ++
+ " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
+ (intercalate "/" . map Node.name $ nodes)
-- | Annotates a solution with the appropriate string.
annotateSolution :: AllocSolution -> AllocSolution
@@ -725,7 +717,7 @@ filterMGResults gl = foldl' fn []
fn accu (gdx, rasol) =
case rasol of
Bad _ -> accu
- Ok sol | null (asSolutions sol) -> accu
+ Ok sol | isNothing (asSolution sol) -> accu
| unallocable gdx -> accu
| otherwise -> (gdx, sol):accu
@@ -736,7 +728,7 @@ sortMGResults :: Group.List
sortMGResults gl sols =
let extractScore (_, _, _, x) = x
solScore (gdx, sol) = (Group.allocPolicy (Container.find gdx gl),
- (extractScore . head . asSolutions) sol)
+ (extractScore . fromJust . asSolution) sol)
in sortBy (comparing solScore) sols
-- | Finds the best group for an instance on a multi-group cluster.
@@ -1150,18 +1142,16 @@ iterateAlloc nl il limit newinst allocnodes ixes cstats =
newlimit = fmap (flip (-) 1) limit
in case tryAlloc nl il newi2 allocnodes of
Bad s -> Bad s
- Ok (AllocSolution { asFailures = errs, asSolutions = sols3 }) ->
+ Ok (AllocSolution { asFailures = errs, asSolution = sols3 }) ->
let newsol = Ok (collapseFailures errs, nl, il, ixes, cstats) in
case sols3 of
- [] -> newsol
- (xnl, xi, _, _):[] ->
+ Nothing -> newsol
+ Just (xnl, xi, _, _) ->
if limit == Just 0
then newsol
else iterateAlloc xnl (Container.add newidx xi il)
newlimit newinst allocnodes (xi:ixes)
(totalResources xnl:cstats)
- _ -> Bad "Internal error: multiple solutions for single\
- \ allocation"
-- | The core of the tiered allocation mode.
tieredAlloc :: Node.List
diff --git a/htools/Ganeti/HTools/IAlloc.hs b/htools/Ganeti/HTools/IAlloc.hs
index aabdd76f9..437e40654 100644
--- a/htools/Ganeti/HTools/IAlloc.hs
+++ b/htools/Ganeti/HTools/IAlloc.hs
@@ -220,13 +220,12 @@ describeSolution = intercalate ", " . Cluster.asLog
formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
formatAllocate il as = do
let info = describeSolution as
- case Cluster.asSolutions as of
- [] -> fail info
- (nl, inst, nodes, _):[] ->
+ case Cluster.asSolution as of
+ Nothing -> fail info
+ Just (nl, inst, nodes, _) ->
do
let il' = Container.add (Instance.idx inst) inst il
return (info, showJSON $ map Node.name nodes, nl, il')
- _ -> fail "Internal error: multiple allocation solutions"
-- | Convert a node-evacuation/change group result.
formatNodeEvac :: Group.List
diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
index 305a2bee7..f8cc19b60 100644
--- a/htools/Ganeti/HTools/QC.hs
+++ b/htools/Ganeti/HTools/QC.hs
@@ -860,13 +860,12 @@ prop_ClusterAlloc_sane node inst =
Cluster.tryAlloc nl il inst' of
Types.Bad _ -> False
Types.Ok as ->
- case Cluster.asSolutions as of
- [] -> False
- (xnl, xi, _, cv):[] ->
+ case Cluster.asSolution as of
+ Nothing -> False
+ Just (xnl, xi, _, cv) ->
let il' = Container.add (Instance.idx xi) xi il
tbl = Cluster.Table xnl il' cv []
in not (canBalance tbl True 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
@@ -903,16 +902,15 @@ prop_ClusterAllocEvac node inst =
Cluster.tryAlloc nl il inst' of
Types.Bad _ -> False
Types.Ok as ->
- case Cluster.asSolutions as of
- [] -> False
- (xnl, xi, _, _):[] ->
+ case Cluster.asSolution as of
+ Nothing -> False
+ Just (xnl, xi, _, _) ->
let sdx = Instance.sNode xi
il' = Container.add (Instance.idx xi) xi il
in case IAlloc.processRelocate defGroupList xnl il'
(Instance.idx xi) 1 [sdx] of
Types.Ok _ -> True
_ -> False
- _ -> False
-- | Check that allocating multiple instances on a cluster, then
-- adding an empty node, results in a valid rebalance.
--
GitLab