From 859fc11d27d3efb7eef980b64dca2fe17e175d92 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Thu, 2 Dec 2010 16:39:56 +0000
Subject: [PATCH] Add a 'log' attribute to allocation solutions

And also a couple of functions for describing a given solution; these
will be used in the future instead of the ones currently in hail.

The patch also enhances the description of failure messages.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Balazs Lecz <leczb@google.com>
---
 Ganeti/HTools/Cluster.hs |   36 ++++++++++++++++++++++++++++++------
 1 file changed, 30 insertions(+), 6 deletions(-)

diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index 09b2814..4c9636c 100644
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -87,13 +87,13 @@ data AllocSolution = AllocSolution
   , asSolutions :: [Node.AllocElement] -- ^ The actual result, length
                                        -- of the list depends on the
                                        -- allocation/relocation mode
-
+  , asLog       :: [String]            -- ^ A list of informational messages
   }
 
 -- | The empty solution we start with when computing allocations
 emptySolution :: AllocSolution
 emptySolution = AllocSolution { asFailures = [], asAllocs = 0
-                              , asSolutions = [] }
+                              , asSolutions = [], asLog = [] }
 
 -- | The complete state for the balancing solution
 data Table = Table Node.List Instance.List Score [Placement]
@@ -569,6 +569,28 @@ concatAllocs as (OpGood ns@(_, _, _, nscore)) =
     -- elements of the tuple
     in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolutions = nsols }
 
+-- | Given a solution, generates a reasonable description for it
+describeSolution :: AllocSolution -> String
+describeSolution as =
+  let fcnt = asFailures as
+      sols = asSolutions 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)
+
+-- | Annotates a solution with the appropriate string
+annotateSolution :: AllocSolution -> AllocSolution
+annotateSolution as = as { asLog = describeSolution as : asLog as }
+
 -- | Try to allocate an instance on the cluster.
 tryAlloc :: (Monad m) =>
             Node.List         -- ^ The node list
@@ -583,14 +605,15 @@ tryAlloc nl _ inst 2 =
         sols = foldl' (\cstate (p, s) ->
                            concatAllocs cstate $ allocateOnPair nl inst p s
                       ) emptySolution ok_pairs
-    in return sols
+
+    in return $ annotateSolution sols
 
 tryAlloc nl _ inst 1 =
     let all_nodes = getOnline nl
         sols = foldl' (\cstate ->
                            concatAllocs cstate . allocateOnSingle nl inst
                       ) emptySolution all_nodes
-    in return sols
+    in return $ annotateSolution sols
 
 tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
                              \destinations required (" ++ show reqn ++
@@ -649,9 +672,10 @@ tryEvac nl il ex_ndx =
                               -- this relocation failed, so we fail
                               -- the entire evac
                               _ -> fail $ "Can't evacuate instance " ++
-                                   Instance.name (Container.find idx il)
+                                   Instance.name (Container.find idx il) ++
+                                   ": " ++ describeSolution new_as
                         ) (nl, emptySolution) all_insts
-      return sol
+      return $ annotateSolution sol
 
 -- | Recursively place instances on the cluster until we're out of space
 iterateAlloc :: Node.List
-- 
1.7.10.4