Fix unittests

[ganeti-local] / hail.hs

diff --git a/hail.hs b/hail.hs
index a8b1c07..d216a46 100644 (file)
--- a/hail.hs
+++ b/hail.hs
@@ -2,11 +2,31 @@
 
 -}
 
 
 -}
 

+{-
+
+Copyright (C) 2009 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+

 module Main (main) where
 
 import Data.List
 import Data.Function
 module Main (main) where
 
 import Data.List
 import Data.Function

-import Data.Maybe (isJust, fromJust)

 import Monad
 import System
 import System.IO
 import Monad
 import System
 import System.IO

@@ -15,7 +35,6 @@ import qualified System
 
 import Text.Printf (printf)
 
 
 import Text.Printf (printf)
 

-import qualified Ganeti.HTools.Container as Container

 import qualified Ganeti.HTools.Cluster as Cluster
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Cluster as Cluster
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Instance as Instance

@@ -52,70 +71,21 @@ options =
       "show help"
     ]
 
       "show help"
     ]
 

--- | Compute online nodes from a Node.List
-getOnline :: Node.List -> [Node.Node]
-getOnline = filter (not . Node.offline) . Container.elems
-
--- | Try to allocate an instance on the cluster
-tryAlloc :: (Monad m) =>
-            Node.List
-         -> Instance.List
-         -> Instance.Instance
-         -> Int
-         -> m [(Maybe Node.List, [Node.Node])]
-tryAlloc nl _ inst 2 =
-    let all_nodes = getOnline nl
-        all_pairs = liftM2 (,) all_nodes all_nodes
-        ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
-        sols = map (\(p, s) ->
-                        (fst $ Cluster.allocateOnPair nl inst p s, [p, s]))
-               ok_pairs
-    in return sols
-
-tryAlloc nl _ inst 1 =
-    let all_nodes = getOnline nl
-        sols = map (\p -> (fst $ Cluster.allocateOnSingle nl inst p, [p]))
-               all_nodes
-    in return sols
-
-tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
-                             \destinations required (" ++ (show reqn) ++
-                                               "), only two supported"
-
--- | Try to allocate an instance on the cluster
-tryReloc :: (Monad m) =>
-            Node.List
-         -> Instance.List
-         -> Idx
-         -> Int
-         -> [Ndx]
-         -> m [(Maybe Node.List, [Node.Node])]
-tryReloc nl il xid 1 ex_idx =
-    let all_nodes = getOnline nl
-        inst = Container.find xid il
-        ex_idx' = (Instance.pnode inst):ex_idx
-        valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
-        valid_idxes = map Node.idx valid_nodes
-        sols1 = map (\x -> let (mnl, _, _, _) =
-                                    Cluster.applyMove nl inst
-                                               (Cluster.ReplaceSecondary x)
-                            in (mnl, [Container.find x nl])
-                     ) valid_idxes
-    in return sols1
-
-tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
-                                \destinations required (" ++ (show reqn) ++
-                                                  "), only one supported"
-
-filterFails :: (Monad m) => [(Maybe Node.List, [Node.Node])]
+
+filterFails :: (Monad m) => [(OpResult Node.List,
+                              Instance.Instance, [Node.Node])]

             -> m [(Node.List, [Node.Node])]
 filterFails sols =
     if null sols then fail "No nodes onto which to allocate at all"
             -> m [(Node.List, [Node.Node])]
 filterFails sols =
     if null sols then fail "No nodes onto which to allocate at all"

-    else let sols' = filter (isJust . fst) sols
-         in if null sols' then
-                fail "No valid allocation solutions"
-            else
-                return $ map (\(x, y) -> (fromJust x, y)) sols'
+    else let sols' = concatMap (\ (onl, _, nn) ->
+                                    case onl of
+                                      OpFail _ -> []
+                                      OpGood gnl -> [(gnl, nn)]
+                               ) sols
+         in
+           if null sols'
+           then fail "No valid allocation solutions"
+           else return sols'

 
 processResults :: (Monad m) => [(Node.List, [Node.Node])]
                -> m (String, [Node.Node])
 
 processResults :: (Monad m) => [(Node.List, [Node.Node])]
                -> m (String, [Node.Node])

@@ -127,9 +97,18 @@ processResults sols =
         info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
                       \worst score: %.8f for node(s) %s" (length sols'')
                       best (intercalate "/" . map Node.name $ w)
         info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
                       \worst score: %.8f for node(s) %s" (length sols'')
                       best (intercalate "/" . map Node.name $ w)

-                      worst (intercalate "/" . map Node.name $ l)
+                      worst (intercalate "/" . map Node.name $ l)::String

     in return (info, w)
 
     in return (info, w)
 

+-- | Process a request and return new node lists
+processRequest :: Request
+               -> Result [(OpResult Node.List, Instance.Instance, [Node.Node])]
+processRequest request =
+  let Request rqtype nl il _ = request
+  in case rqtype of
+       Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
+       Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
+

 -- | Main function.
 main :: IO ()
 main = do
 -- | Main function.
 main :: IO ()
 main = do

@@ -145,16 +124,12 @@ main = do
 
   request <- case (parseData input_data) of
                Bad err -> do
 
   request <- case (parseData input_data) of
                Bad err -> do

-                 putStrLn $ "Error: " ++ err
+                 hPutStrLn stderr $ "Error: " ++ err

                  exitWith $ ExitFailure 1
                Ok rq -> return rq
 
                  exitWith $ ExitFailure 1
                Ok rq -> return rq
 

-  let Request rqtype nl il csf = request
-      new_nodes = case rqtype of
-                    Allocate xi reqn -> tryAlloc nl il xi reqn
-                    Relocate idx reqn exnodes ->
-                        tryReloc nl il idx reqn exnodes
-  let sols = new_nodes >>= filterFails >>= processResults
+  let Request _ _ _ csf = request
+      sols = processRequest request >>= filterFails >>= processResults

   let (ok, info, rn) = case sols of
                Ok (info, sn) -> (True, "Request successful: " ++ info,
                                      map ((++ csf) . Node.name) sn)
   let (ok, info, rn) = case sols of
                Ok (info, sn) -> (True, "Request successful: " ++ info,
                                      map ((++ csf) . Node.name) sn)