, formatCmds
, printNodes
-- * Balacing functions
- , applyMove
, checkMove
, compCV
, printStats
-- * IAllocator functions
- , allocateOnSingle
- , allocateOnPair
, tryAlloc
, tryReloc
+ , collapseFailures
) where
import Data.List
type Placement = (Idx, Ndx, Ndx, Score)
-- | Allocation\/relocation solution.
-type AllocSolution = [(OpResult Node.List, Instance.Instance, [Node.Node])]
+type AllocSolution = ([FailMode], Int, Maybe (Score, AllocElement))
+
+-- | Allocation\/relocation element.
+type AllocElement = (Node.List, Instance.Instance, [Node.Node])
-- | An instance move definition
data IMove = Failover -- ^ Failover the instance (f)
data Table = Table Node.List Instance.List Score [Placement]
deriving (Show)
-data CStats = CStats { cs_fmem :: Int -- ^ Cluster free mem
- , cs_fdsk :: Int -- ^ Cluster free disk
- , cs_amem :: Int -- ^ Cluster allocatable mem
- , cs_adsk :: Int -- ^ Cluster allocatable disk
- , cs_acpu :: Int -- ^ Cluster allocatable cpus
- , cs_mmem :: Int -- ^ Max node allocatable mem
- , cs_mdsk :: Int -- ^ Max node allocatable disk
- , cs_mcpu :: Int -- ^ Max node allocatable cpu
+data CStats = CStats { cs_fmem :: Int -- ^ Cluster free mem
+ , cs_fdsk :: Int -- ^ Cluster free disk
+ , cs_amem :: Int -- ^ Cluster allocatable mem
+ , cs_adsk :: Int -- ^ Cluster allocatable disk
+ , cs_acpu :: Int -- ^ Cluster allocatable cpus
+ , cs_mmem :: Int -- ^ Max node allocatable mem
+ , cs_mdsk :: Int -- ^ Max node allocatable disk
+ , cs_mcpu :: Int -- ^ Max node allocatable cpu
+ , cs_imem :: Int -- ^ Instance used mem
+ , cs_idsk :: Int -- ^ Instance used disk
+ , cs_icpu :: Int -- ^ Instance used cpu
+ , cs_tmem :: Double -- ^ Cluster total mem
+ , cs_tdsk :: Double -- ^ Cluster total disk
+ , cs_tcpu :: Double -- ^ Cluster total cpus
+ , cs_xmem :: Int -- ^ Unnacounted for mem
+ , cs_nmem :: Int -- ^ Node own memory
+ , cs_score :: Score -- ^ The cluster score
+ , cs_ninst :: Int -- ^ The total number of instances
}
-- * Utility functions
, cs_mmem = 0
, cs_mdsk = 0
, cs_mcpu = 0
+ , cs_imem = 0
+ , cs_idsk = 0
+ , cs_icpu = 0
+ , cs_tmem = 0
+ , cs_tdsk = 0
+ , cs_tcpu = 0
+ , cs_xmem = 0
+ , cs_nmem = 0
+ , cs_score = 0
+ , cs_ninst = 0
}
updateCStats :: CStats -> Node.Node -> CStats
updateCStats cs node =
let CStats { cs_fmem = x_fmem, cs_fdsk = x_fdsk,
cs_amem = x_amem, cs_acpu = x_acpu, cs_adsk = x_adsk,
- cs_mmem = x_mmem, cs_mdsk = x_mdsk, cs_mcpu = x_mcpu }
+ cs_mmem = x_mmem, cs_mdsk = x_mdsk, cs_mcpu = x_mcpu,
+ cs_imem = x_imem, cs_idsk = x_idsk, cs_icpu = x_icpu,
+ cs_tmem = x_tmem, cs_tdsk = x_tdsk, cs_tcpu = x_tcpu,
+ cs_xmem = x_xmem, cs_nmem = x_nmem, cs_ninst = x_ninst
+ }
= cs
inc_amem = Node.f_mem node - Node.r_mem node
inc_amem' = if inc_amem > 0 then inc_amem else 0
inc_adsk = Node.availDisk node
- in CStats { cs_fmem = x_fmem + Node.f_mem node
- , cs_fdsk = x_fdsk + Node.f_dsk node
- , cs_amem = x_amem + inc_amem'
- , cs_adsk = x_adsk + inc_adsk
- , cs_acpu = x_acpu
- , cs_mmem = max x_mmem inc_amem'
- , cs_mdsk = max x_mdsk inc_adsk
- , cs_mcpu = x_mcpu
- }
+ inc_imem = truncate (Node.t_mem node) - Node.n_mem node
+ - Node.x_mem node - Node.f_mem node
+ inc_icpu = Node.u_cpu node
+ inc_idsk = truncate (Node.t_dsk node) - Node.f_dsk node
+
+ in cs { cs_fmem = x_fmem + Node.f_mem node
+ , cs_fdsk = x_fdsk + Node.f_dsk node
+ , cs_amem = x_amem + inc_amem'
+ , cs_adsk = x_adsk + inc_adsk
+ , cs_acpu = x_acpu
+ , cs_mmem = max x_mmem inc_amem'
+ , cs_mdsk = max x_mdsk inc_adsk
+ , cs_mcpu = x_mcpu
+ , cs_imem = x_imem + inc_imem
+ , cs_idsk = x_idsk + inc_idsk
+ , cs_icpu = x_icpu + inc_icpu
+ , cs_tmem = x_tmem + Node.t_mem node
+ , cs_tdsk = x_tdsk + Node.t_dsk node
+ , cs_tcpu = x_tcpu + Node.t_cpu node
+ , cs_xmem = x_xmem + Node.x_mem node
+ , cs_nmem = x_nmem + Node.n_mem node
+ , cs_ninst = x_ninst + length (Node.plist node)
+ }
-- | Compute the total free disk and memory in the cluster.
totalResources :: Node.List -> CStats
-totalResources = foldl' updateCStats emptyCStats . Container.elems
+totalResources nl =
+ let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
+ in cs { cs_score = compCV nl }
-- | Compute the mem and disk covariance.
compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double, Double)
(length . Node.slist $ n)) $ offline
online_inst = sum . map (\n -> (length . Node.plist $ n) +
(length . Node.slist $ n)) $ nodes
- off_score = fromIntegral offline_inst /
- fromIntegral (online_inst + offline_inst)::Double
+ off_score = if offline_inst == 0
+ then 0::Double
+ else fromIntegral offline_inst /
+ fromIntegral (offline_inst + online_inst)::Double
cpu_l = map Node.p_cpu nodes
cpu_cv = varianceCoeff cpu_l
in (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv)
-- | Applies an instance move to a given node list and instance.
applyMove :: Node.List -> Instance.Instance
- -> IMove -> (OpResult 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
new_nl = do -- Maybe monad
new_p <- Node.addPri int_s inst
new_s <- Node.addSec int_p inst old_sdx
- return $ Container.addTwo old_pdx new_s old_sdx new_p nl
- in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
+ let new_inst = Instance.setBoth inst old_sdx old_pdx
+ return (Container.addTwo old_pdx new_s old_sdx new_p nl,
+ new_inst, old_sdx, old_pdx)
+ in new_nl
-- Replace the primary (f:, r:np, f)
applyMove nl inst (ReplacePrimary new_pdx) =
let tmp_s' = Node.removePri tmp_s inst
new_p <- Node.addPri tgt_n inst
new_s <- Node.addSec tmp_s' inst new_pdx
- return . Container.add new_pdx new_p $
- Container.addTwo old_pdx int_p old_sdx new_s nl
- in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
+ let new_inst = Instance.setPri inst new_pdx
+ return (Container.add new_pdx new_p $
+ Container.addTwo old_pdx int_p old_sdx new_s nl,
+ new_inst, new_pdx, old_sdx)
+ in new_nl
-- Replace the secondary (r:ns)
applyMove nl inst (ReplaceSecondary new_sdx) =
old_s = Container.find old_sdx nl
tgt_n = Container.find new_sdx nl
int_s = Node.removeSec old_s inst
+ new_inst = Instance.setSec inst new_sdx
new_nl = Node.addSec tgt_n inst old_pdx >>=
- \new_s -> return $ Container.addTwo new_sdx
- new_s old_sdx int_s nl
- in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
+ \new_s -> return (Container.addTwo new_sdx
+ new_s old_sdx int_s nl,
+ new_inst, old_pdx, new_sdx)
+ in new_nl
-- Replace the secondary and failover (r:np, f)
applyMove nl inst (ReplaceAndFailover new_pdx) =
new_nl = do -- Maybe monad
new_p <- Node.addPri tgt_n inst
new_s <- Node.addSec int_p inst new_pdx
- return . Container.add new_pdx new_p $
- Container.addTwo old_pdx new_s old_sdx int_s nl
- in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
+ let new_inst = Instance.setBoth inst new_pdx old_pdx
+ return (Container.add new_pdx new_p $
+ Container.addTwo old_pdx new_s old_sdx int_s nl,
+ new_inst, new_pdx, old_pdx)
+ in new_nl
-- Failver and replace the secondary (f, r:ns)
applyMove nl inst (FailoverAndReplace new_sdx) =
new_nl = do -- Maybe monad
new_p <- Node.addPri int_s inst
new_s <- Node.addSec tgt_n inst old_sdx
- return . Container.add new_sdx new_s $
- Container.addTwo old_sdx new_p old_pdx int_p nl
- in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
+ let new_inst = Instance.setBoth inst old_sdx new_sdx
+ return (Container.add new_sdx new_s $
+ Container.addTwo old_sdx new_p old_pdx int_p nl,
+ new_inst, old_sdx, new_sdx)
+ in new_nl
-- | Tries to allocate an instance on one given node.
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
- -> (OpResult Node.List, Instance.Instance)
+ -> OpResult AllocElement
allocateOnSingle nl inst p =
let new_pdx = Node.idx p
+ new_inst = Instance.setBoth inst new_pdx Node.noSecondary
new_nl = Node.addPri p inst >>= \new_p ->
- return $ Container.add new_pdx new_p nl
- in (new_nl, Instance.setBoth inst new_pdx Node.noSecondary)
+ return (Container.add new_pdx new_p nl, new_inst, [new_p])
+ in new_nl
-- | Tries to allocate an instance on a given pair of nodes.
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
- -> (OpResult Node.List, Instance.Instance)
+ -> OpResult AllocElement
allocateOnPair nl inst tgt_p tgt_s =
let new_pdx = Node.idx tgt_p
new_sdx = Node.idx tgt_s
new_nl = do -- Maybe monad
new_p <- Node.addPri tgt_p inst
new_s <- Node.addSec tgt_s inst new_pdx
- return $ Container.addTwo new_pdx new_p new_sdx new_s nl
- in (new_nl, Instance.setBoth inst new_pdx new_sdx)
+ let new_inst = Instance.setBoth inst new_pdx new_sdx
+ return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
+ [new_p, new_s])
+ in new_nl
-- | Tries to perform an instance move and returns the best table
-- between the original one and the new one.
checkSingleStep ini_tbl target cur_tbl move =
let
Table ini_nl ini_il _ ini_plc = ini_tbl
- (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
+ tmp_resu = applyMove ini_nl target move
in
- case tmp_nl of
+ case tmp_resu of
OpFail _ -> cur_tbl
- OpGood upd_nl ->
+ OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
let tgt_idx = Instance.idx target
upd_cvar = compCV upd_nl
upd_il = Container.add tgt_idx new_inst ini_il
else
best_tbl
--- * Alocation functions
+-- * Allocation functions
+
+-- | Build failure stats out of a list of failures
+collapseFailures :: [FailMode] -> FailStats
+collapseFailures flst =
+ map (\k -> (k, length $ filter ((==) k) flst)) [minBound..maxBound]
+
+-- | Update current Allocation solution and failure stats with new
+-- elements
+concatAllocs :: AllocSolution -> OpResult AllocElement -> AllocSolution
+concatAllocs (flst, succ, sols) (OpFail reason) = (reason:flst, succ, sols)
+
+concatAllocs (flst, succ, osols) (OpGood ns@(nl, _, _)) =
+ let nscore = compCV nl
+ -- Choose the old or new solution, based on the cluster score
+ nsols = case osols of
+ Nothing -> Just (nscore, ns)
+ Just (oscore, _) ->
+ if oscore < nscore
+ then osols
+ else Just (nscore, ns)
+ nsuc = succ + 1
+ -- Note: we force evaluation of nsols here in order to keep the
+ -- memory profile low - we know that we will need nsols for sure
+ -- in the next cycle, so we force evaluation of nsols, since the
+ -- foldl' in the caller will only evaluate the tuple, but not the
+ -- elements of the tuple
+ in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
-- | Try to allocate an instance on the cluster.
tryAlloc :: (Monad m) =>
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) -> let (mnl, i) = allocateOnPair nl inst p s
- in (mnl, i, [p, s]))
- ok_pairs
+ sols = foldl' (\cstate (p, s) ->
+ concatAllocs cstate $ allocateOnPair nl inst p s
+ ) ([], 0, Nothing) ok_pairs
in return sols
tryAlloc nl _ inst 1 =
let all_nodes = getOnline nl
- sols = map (\p -> let (mnl, i) = allocateOnSingle nl inst p
- in (mnl, i, [p]))
- all_nodes
+ sols = foldl' (\cstate p ->
+ concatAllocs cstate $ allocateOnSingle nl inst p
+ ) ([], 0, Nothing) all_nodes
in return sols
-tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
+tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
\destinations required (" ++ show reqn ++
"), only two supported"
Node.List -- ^ The node list
-> Instance.List -- ^ The instance list
-> Idx -- ^ The index of the instance to move
- -> Int -- ^ The numver of nodes required
+ -> Int -- ^ The number of nodes required
-> [Ndx] -- ^ Nodes which should not be used
-> m AllocSolution -- ^ Solution list
tryReloc nl il xid 1 ex_idx =
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, i, _, _) =
- applyMove nl inst (ReplaceSecondary x)
- in (mnl, i, [Container.find x nl])
- ) valid_idxes
+ sols1 = foldl' (\cstate x ->
+ let elem = do
+ (mnl, i, _, _) <-
+ applyMove nl inst (ReplaceSecondary x)
+ return (mnl, i, [Container.find x mnl])
+ in concatAllocs cstate elem
+ ) ([], 0, Nothing) valid_idxes
in return sols1
tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
-- either @/f/@ for failover or @/r:name/@ for replace
-- secondary, while the command list holds gnt-instance
-- commands (without that prefix), e.g \"@failover instance1@\"
-computeMoves i a b c d =
- if c == a then {- Same primary -}
- if d == b then {- Same sec??! -}
- ("-", [])
+computeMoves i a b c d
+ -- same primary
+ | c == a =
+ if d == b
+ then {- Same sec??! -} ("-", [])
else {- Change of secondary -}
- (printf "r:%s" d,
- [printf "replace-disks -n %s %s" d i])
- else
- if c == b then {- Failover and ... -}
- if d == a then {- that's all -}
- ("f", [printf "migrate -f %s" i])
- else
- (printf "f r:%s" d,
- [printf "migrate -f %s" i,
- printf "replace-disks -n %s %s" d i])
- else
- if d == a then {- ... and keep primary as secondary -}
- (printf "r:%s f" c,
- [printf "replace-disks -n %s %s" c i,
- printf "migrate -f %s" i])
- else
- if d == b then {- ... keep same secondary -}
- (printf "f r:%s f" c,
- [printf "migrate -f %s" i,
- printf "replace-disks -n %s %s" c i,
- printf "migrate -f %s" i])
-
- else {- Nothing in common -}
- (printf "r:%s f r:%s" c d,
- [printf "replace-disks -n %s %s" c i,
- printf "migrate -f %s" i,
- printf "replace-disks -n %s %s" d i])
+ (printf "r:%s" d, [rep d])
+ -- failover and ...
+ | c == b =
+ if d == a
+ then {- that's all -} ("f", [mig])
+ else (printf "f r:%s" d, [mig, rep d])
+ -- ... and keep primary as secondary
+ | d == a =
+ (printf "r:%s f" c, [rep c, mig])
+ -- ... keep same secondary
+ | d == b =
+ (printf "f r:%s f" c, [mig, rep c, mig])
+ -- nothing in common -
+ | otherwise =
+ (printf "r:%s f r:%s" c d, [rep c, mig, rep d])
+ where mig = printf "migrate -f %s" i::String
+ rep n = printf "replace-disks -n %s %s" n i
-- | Converts a placement to string format.
printSolutionLine :: Node.List -- ^ The node list
projects / ganeti-local / blobdiff