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>

diff --git a/htools/Ganeti/HTools/Cluster.hs b/htools/Ganeti/HTools/Cluster.hs
index 3d1b9f2..bb00ce1 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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.