LGTM
On Mon, Sep 26, 2011 at 12:08 PM, Iustin Pop <[email protected]> wrote: > 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. > --- > 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 3d1b9f2..bb00ce1 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 aabdd76..437e406 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 305a2be..f8cc19b 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. > -- > 1.7.3.1 > >
