From f2280553304850448234b792c9423bd80609d401 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Sun, 5 Jul 2009 15:53:40 +0300
Subject: [PATCH] Introduce a new type for allocation results
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Currently the allocation/move operations workflow return βMaybe aβ,
which is very convenient but loses all details about the failure mode.
This patch introduces a new data type which encodes the specific failure
mode. It is not yet used correctly (e.g. all node operations result in
FailN1), but the workflow is updated.Β Most of the changes are in the
hail/hspace tools, the library code required only trivial adjustments.
---
Ganeti/HTools/Cluster.hs | 29 ++++++++++++------------
Ganeti/HTools/Node.hs | 22 +++++++++---------
Ganeti/HTools/Types.hs | 17 ++++++++++++++
hail.hs | 25 ++++++++++++---------
hspace.hs | 48 ++++++++++++++++++++++------------------
5 files changed, 83 insertions(+), 58 deletions(-)
diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index efe9d34e4..4eb07c362 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 34210ccd1..db5e402e2 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 662cef2c0..3a494f7f7 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 ae8e11276..3503b5bf0 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 4a5c2f18d..ec7df9c68 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
--
GitLab