X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/78ecfa8f4edb5044e67d5c96b604623a1d06ba71..44763b519ffda6e7ddb35b9d7c0b823fd7f9ccec:/hspace.hs

diff --git a/hspace.hs b/hspace.hs
index 4a5c2f1..a6d4581 100644
--- a/hspace.hs
+++ b/hspace.hs
@@ -27,7 +27,6 @@ module Main (main) where
 
 import Data.List
 import Data.Function
-import Data.Maybe (isJust, fromJust, isNothing)
 import Monad
 import System
 import System.IO
@@ -43,6 +42,7 @@ import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.CLI as CLI
 
 import Ganeti.HTools.Utils
+import Ganeti.HTools.Types
 
 -- | Command line options structure.
 data Options = Options
@@ -147,45 +147,55 @@ options =
       "show help"
     ]
 
+concatFailure :: [(FailMode, Int)] -> FailMode -> [(FailMode, Int)]
+concatFailure flst reason =
+    let cval = lookup reason flst
+    in case cval of
+         Nothing -> (reason, 1):flst
+         Just val -> let plain = filter (\(x, _) -> x /= reason) flst
+                     in (reason, val+1):plain
+
 filterFails :: Cluster.AllocSolution
-            -> Maybe [(Node.List, Instance.Instance, [Node.Node])]
+            -> ([(FailMode, Int)],
+                [(Node.List, Instance.Instance, [Node.Node])])
 filterFails sols =
-    if null sols then Nothing -- No nodes onto which to allocate at all
-    else let sols' = filter (isJust . fst3) sols
-         in if null sols' then
-                Nothing -- No valid allocation solutions
-            else
-                return $ map (\(x, y, z) -> (fromJust x, y, z)) sols'
-
-processResults :: (Monad m) => [(Node.List, Instance.Instance, [Node.Node])]
-               -> m (Node.List, Instance.Instance, [Node.Node])
+    let (alst, blst) = unzip . map (\ (onl, i, nn) ->
+                                        case onl of
+                                          OpFail reason -> ([reason], [])
+                                          OpGood gnl -> ([], [(gnl, i, nn)])
+                                   ) $ sols
+        aval = concat alst
+        bval = concat blst
+    in (foldl' concatFailure [] aval, bval)
+
+processResults :: [(Node.List, Instance.Instance, [Node.Node])]
+               -> (Node.List, Instance.Instance, [Node.Node])
 processResults sols =
     let sols' = map (\e@(nl', _, _) -> (Cluster.compCV  nl', e)) sols
         sols'' = sortBy (compare `on` fst) sols'
-    in return $ snd $ head sols''
+    in snd $ head sols''
 
 iterateDepth :: Node.List
              -> Instance.List
              -> Instance.Instance
              -> Int
              -> [Instance.Instance]
-             -> (Node.List, [Instance.Instance])
+             -> ([(FailMode, Int)], Node.List, [Instance.Instance])
 iterateDepth nl il newinst nreq ixes =
       let depth = length ixes
           newname = (printf "new-%d" depth)::String
           newidx = (length $ Container.elems il) + depth
           newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
           sols = (Cluster.tryAlloc nl il newi2 nreq)::
-                 Maybe Cluster.AllocSolution
-          orig = (nl, ixes)
-      in
-        if isNothing sols then orig
-        else let sols' = fromJust sols
-                 sols'' = filterFails sols'
-             in if isNothing sols'' then orig
-                else let (xnl, xi, _) = fromJust $ processResults $
-                                        fromJust sols''
-                     in iterateDepth xnl il newinst nreq (xi:ixes)
+                 OpResult Cluster.AllocSolution
+      in case sols of
+           OpFail _ -> ([], nl, ixes)
+           OpGood sols' ->
+               let (errs, sols3) = filterFails sols'
+               in if null sols3
+                  then (errs, nl, ixes)
+                  else let (xnl, xi, _) = processResults sols3
+                       in iterateDepth xnl il newinst nreq (xi:ixes)
 
 printStats :: String -> Cluster.CStats -> IO ()
 printStats kind cs = do
@@ -269,12 +279,13 @@ main = do
       newinst = Instance.create "new" (optIMem opts) (optIDsk opts)
                 (optIVCPUs opts) "ADMIN_down" (-1) (-1)
 
-  let (fin_nl, ixes) = iterateDepth nl il newinst req_nodes []
+  let (ereason, fin_nl, ixes) = iterateDepth nl il newinst req_nodes []
       allocs = length ixes
       fin_instances = num_instances + allocs
       fin_ixes = reverse ixes
       ix_namelen = maximum . map (length . Instance.name) $ fin_ixes
       fin_stats = Cluster.totalResources fin_nl
+      sreason = reverse $ sortBy (compare `on` snd) ereason
 
   printf "Final score: %.8f\n" (Cluster.compCV fin_nl)
   printf "Final instances: %d\n" (num_instances + allocs)
@@ -282,6 +293,9 @@ main = do
   printf "Usage: %.5f\n" (((fromIntegral num_instances)::Double) /
                           (fromIntegral fin_instances))
   printf "Allocations: %d\n" allocs
+  putStr (unlines . map (\(x, y) -> printf "%s: %d" (show x) y) $ sreason)
+  printf "Most likely fail reason: %s\n" (show . fst . head $ sreason)
+
   when (verbose > 1) $ do
          putStr . unlines . map (\i -> printf "Inst: %*s %-*s %-*s"
                      ix_namelen (Instance.name i)