diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index efe9d34e47aae9566386b9d30f016018e8760fd9..4eb07c362b02c5ab50194e63817c7f1ed4d0fa01 100644
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -57,7 +57,6 @@ module Ganeti.HTools.Cluster
) where
import Data.List
-import Data.Maybe (isNothing, fromJust)
import Text.Printf (printf)
import Data.Function
import Control.Monad
@@ -77,7 +76,7 @@ type Score = Double
type Placement = (Idx, Ndx, Ndx, Score)
-- | Allocation\/relocation solution.
-type AllocSolution = [(Maybe Node.List, Instance.Instance, [Node.Node])]
+type AllocSolution = [(OpResult Node.List, Instance.Instance, [Node.Node])]
-- | An instance move definition
data IMove = Failover -- ^ Failover the instance (f)
@@ -203,7 +202,7 @@ compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
-- | Applies an instance move to a given node list and instance.
applyMove :: Node.List -> Instance.Instance
- -> IMove -> (Maybe Node.List, Instance.Instance, Ndx, Ndx)
+ -> IMove -> (OpResult Node.List, Instance.Instance, Ndx, Ndx)
-- Failover (f)
applyMove nl inst Failover =
let old_pdx = Instance.pnode inst
@@ -284,7 +283,7 @@ applyMove nl inst (FailoverAndReplace new_sdx) =
-- | Tries to allocate an instance on one given node.
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
- -> (Maybe Node.List, Instance.Instance)
+ -> (OpResult Node.List, Instance.Instance)
allocateOnSingle nl inst p =
let new_pdx = Node.idx p
new_nl = Node.addPri p inst >>= \new_p ->
@@ -293,7 +292,7 @@ allocateOnSingle nl inst p =
-- | Tries to allocate an instance on a given pair of nodes.
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
- -> (Maybe Node.List, Instance.Instance)
+ -> (OpResult Node.List, Instance.Instance)
allocateOnPair nl inst tgt_p tgt_s =
let new_pdx = Node.idx tgt_p
new_sdx = Node.idx tgt_s
@@ -315,16 +314,16 @@ checkSingleStep ini_tbl target cur_tbl move =
Table ini_nl ini_il _ ini_plc = ini_tbl
(tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
in
- if isNothing tmp_nl then cur_tbl
- else
- let tgt_idx = Instance.idx target
- upd_nl = fromJust tmp_nl
- upd_cvar = compCV upd_nl
- upd_il = Container.add tgt_idx new_inst ini_il
- upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
- upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
- in
- compareTables cur_tbl upd_tbl
+ case tmp_nl of
+ OpFail _ -> cur_tbl
+ OpGood upd_nl ->
+ let tgt_idx = Instance.idx target
+ upd_cvar = compCV upd_nl
+ upd_il = Container.add tgt_idx new_inst ini_il
+ upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
+ upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
+ in
+ compareTables cur_tbl upd_tbl
-- | Given the status of the current secondary as a valid new node
-- and the current candidate target node,
diff --git a/Ganeti/HTools/Node.hs b/Ganeti/HTools/Node.hs
index 34210ccd19c711af8cec3bcf2f8e43ba79931e74..db5e402e2c38bf79879549614740346ee4b01a7a 100644
--- a/Ganeti/HTools/Node.hs
+++ b/Ganeti/HTools/Node.hs
@@ -294,7 +294,7 @@ removeSec t inst =
p_rem = new_prem}
-- | Adds a primary instance.
-addPri :: Node -> Instance.Instance -> Maybe Node
+addPri :: Node -> Instance.Instance -> T.OpResult Node
addPri t inst =
let iname = Instance.idx inst
new_mem = f_mem t - Instance.mem inst
@@ -307,17 +307,17 @@ addPri t inst =
if (failHealth new_mem new_dsk) || (new_failn1 && not (failN1 t)) ||
(failLimits t new_dp new_pcpu)
then
- Nothing
+ T.OpFail T.FailN1
else
let new_plist = iname:(plist t)
new_mp = (fromIntegral new_mem) / (t_mem t)
in
- Just t {plist = new_plist, f_mem = new_mem, f_dsk = new_dsk,
- failN1 = new_failn1, p_mem = new_mp, p_dsk = new_dp,
- u_cpu = new_ucpu, p_cpu = new_pcpu}
+ T.OpGood t {plist = new_plist, f_mem = new_mem, f_dsk = new_dsk,
+ failN1 = new_failn1, p_mem = new_mp, p_dsk = new_dp,
+ u_cpu = new_ucpu, p_cpu = new_pcpu}
-- | Adds a secondary instance.
-addSec :: Node -> Instance.Instance -> T.Ndx -> Maybe Node
+addSec :: Node -> Instance.Instance -> T.Ndx -> T.OpResult Node
addSec t inst pdx =
let iname = Instance.idx inst
old_peers = peers t
@@ -332,14 +332,14 @@ addSec t inst pdx =
in if (failHealth old_mem new_dsk) || (new_failn1 && not (failN1 t)) ||
(failLimits t new_dp noLimit)
then
- Nothing
+ T.OpFail T.FailN1
else
let new_slist = iname:(slist t)
in
- Just t {slist = new_slist, f_dsk = new_dsk,
- peers = new_peers, failN1 = new_failn1,
- r_mem = new_rmem, p_dsk = new_dp,
- p_rem = new_prem}
+ T.OpGood t {slist = new_slist, f_dsk = new_dsk,
+ peers = new_peers, failN1 = new_failn1,
+ r_mem = new_rmem, p_dsk = new_dp,
+ p_rem = new_prem}
-- * Stats functions
diff --git a/Ganeti/HTools/Types.hs b/Ganeti/HTools/Types.hs
index 662cef2c0b5cd164bfbeb10c683919e1d8ad1dac..3a494f7f7f154cca9b92cb25b12d3dfa5271a96c 100644
--- a/Ganeti/HTools/Types.hs
+++ b/Ganeti/HTools/Types.hs
@@ -29,6 +29,8 @@ module Ganeti.HTools.Types
, NameAssoc
, Result(..)
, Element(..)
+ , FailMode(..)
+ , OpResult(..)
) where
-- | The instance index type.
@@ -58,6 +60,21 @@ instance Monad Result where
return = Ok
fail = Bad
+-- | Reason for an operation's falure
+data FailMode = FailMem -- ^ Failed due to not enough RAM
+ | FailDisk -- ^ Failed due to not enough disk
+ | FailCPU -- ^ Failed due to not enough CPU capacity
+ | FailN1 -- ^ Failed due to not passing N1 checks
+
+-- | Either-like data-type customized for our failure modes
+data OpResult a = OpFail FailMode -- ^ Failed operation
+ | OpGood a -- ^ Success operation
+
+instance Monad OpResult where
+ (OpGood x) >>= fn = fn x
+ (OpFail y) >>= _ = OpFail y
+ return = OpGood
+
-- | A generic class for items that have updateable names and indices.
class Element a where
-- | Returns the name of the element
diff --git a/hail.hs b/hail.hs
index ae8e112766f28bbcbfd33ac56e73ee6dc4fff0c0..3503b5bf03477bad1e122476a6ce41c1af7c44e7 100644
--- a/hail.hs
+++ b/hail.hs
@@ -27,7 +27,6 @@ module Main (main) where
import Data.List
import Data.Function
-import Data.Maybe (isJust, fromJust)
import Monad
import System
import System.IO
@@ -43,7 +42,6 @@ import qualified Ganeti.HTools.CLI as CLI
import Ganeti.HTools.IAlloc
import Ganeti.HTools.Types
import Ganeti.HTools.Loader (RqType(..), Request(..))
-import Ganeti.HTools.Utils
-- | Command line options structure.
data Options = Options
@@ -74,15 +72,21 @@ options =
]
-filterFails :: (Monad m) => [(Maybe Node.List, Instance.Instance, [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"
- else let sols' = filter (isJust . fst3) sols
- in if null sols' then
- fail "No valid allocation solutions"
- else
- return $ map (\(x, _, y) -> (fromJust x, y)) sols'
+ else let sols' = concat . map (\ (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])
@@ -98,9 +102,8 @@ processResults sols =
in return (info, w)
-- | Process a request and return new node lists
-processRequest ::
- Request
- -> Result [(Maybe Node.List, Instance.Instance, [Node.Node])]
+processRequest :: Request
+ -> Result [(OpResult Node.List, Instance.Instance, [Node.Node])]
processRequest request =
let Request rqtype nl il _ = request
in case rqtype of
diff --git a/hspace.hs b/hspace.hs
index 4a5c2f18db26d7a446c88f66303fc24b32529a81..ec7df9c6827b15955c5f6ad2e7acf1f8ed09d225 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
@@ -148,21 +148,25 @@ options =
]
filterFails :: Cluster.AllocSolution
- -> Maybe [(Node.List, Instance.Instance, [Node.Node])]
+ -> OpResult [(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 sols' = concat . map (\ (onl, i, nn) ->
+ case onl of
+ OpFail _ -> []
+ OpGood gnl -> [(gnl, i, nn)]
+ ) $ sols
+ in
+ if null sols' then
+ OpFail FailN1
+ else
+ return sols'
+
+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
@@ -176,16 +180,18 @@ iterateDepth nl il newinst nreq ixes =
newidx = (length $ Container.elems il) + depth
newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
sols = (Cluster.tryAlloc nl il newi2 nreq)::
- Maybe Cluster.AllocSolution
+ OpResult 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)
+ in case sols of
+ OpFail _ -> orig
+ OpGood sols' ->
+ let
+ sols'' = filterFails sols'
+ in case sols'' of
+ OpFail _ -> orig
+ OpGood sols''' ->
+ let (xnl, xi, _) = processResults sols'''
+ in iterateDepth xnl il newinst nreq (xi:ixes)
printStats :: String -> Cluster.CStats -> IO ()
printStats kind cs = do