module Ganeti.HTools.Cluster
(
AllocSolution(..)
, Table(..)
, CStats(..)
, AllocStats
, totalResources
, computeAllocationDelta
, computeBadItems
, printSolutionLine
, formatCmds
, involvedNodes
, splitJobs
, printNodes
, printInsts
, checkMove
, doNextBalance
, tryBalance
, compCV
, compDetailedCV
, printStats
, iMoveToJob
, genAllocNodes
, tryAlloc
, tryMGAlloc
, tryReloc
, tryMGReloc
, tryEvac
, tryMGEvac
, collapseFailures
, iterateAlloc
, tieredAlloc
, tieredSpecMap
, instanceGroup
, findSplitInstances
, splitCluster
) where
import Data.Function (on)
import Data.List
import Data.Ord (comparing)
import Text.Printf (printf)
import Control.Monad
import Control.Parallel.Strategies
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Group as Group
import Ganeti.HTools.Types
import Ganeti.HTools.Utils
import qualified Ganeti.OpCodes as OpCodes
data AllocSolution = AllocSolution
{ asFailures :: [FailMode]
, asAllocs :: Int
, asSolutions :: [Node.AllocElement]
, asLog :: [String]
}
type AllocResult = (FailStats, Node.List, Instance.List,
[Instance.Instance], [CStats])
type AllocNodes = Either [Ndx] [(Ndx, Ndx)]
emptySolution :: AllocSolution
emptySolution = AllocSolution { asFailures = [], asAllocs = 0
, asSolutions = [], asLog = [] }
data Table = Table Node.List Instance.List Score [Placement]
deriving (Show, Read)
data CStats = CStats { csFmem :: Int
, csFdsk :: Int
, csAmem :: Int
, csAdsk :: Int
, csAcpu :: Int
, csMmem :: Int
, csMdsk :: Int
, csMcpu :: Int
, csImem :: Int
, csIdsk :: Int
, csIcpu :: Int
, csTmem :: Double
, csTdsk :: Double
, csTcpu :: Double
, csVcpu :: Int
, csXmem :: Int
, csNmem :: Int
, csScore :: Score
, csNinst :: Int
}
deriving (Show, Read)
type AllocStats = (RSpec, RSpec, RSpec)
verifyN1 :: [Node.Node] -> [Node.Node]
verifyN1 = filter Node.failN1
computeBadItems :: Node.List -> Instance.List ->
([Node.Node], [Instance.Instance])
computeBadItems nl il =
let bad_nodes = verifyN1 $ getOnline nl
bad_instances = map (`Container.find` il) .
sort . nub $
concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
in
(bad_nodes, bad_instances)
emptyCStats :: CStats
emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
updateCStats :: CStats -> Node.Node -> CStats
updateCStats cs node =
let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
csVcpu = x_vcpu,
csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
}
= cs
inc_amem = Node.fMem node Node.rMem node
inc_amem' = if inc_amem > 0 then inc_amem else 0
inc_adsk = Node.availDisk node
inc_imem = truncate (Node.tMem node) Node.nMem node
Node.xMem node Node.fMem node
inc_icpu = Node.uCpu node
inc_idsk = truncate (Node.tDsk node) Node.fDsk node
inc_vcpu = Node.hiCpu node
inc_acpu = Node.availCpu node
in cs { csFmem = x_fmem + Node.fMem node
, csFdsk = x_fdsk + Node.fDsk node
, csAmem = x_amem + inc_amem'
, csAdsk = x_adsk + inc_adsk
, csAcpu = x_acpu + inc_acpu
, csMmem = max x_mmem inc_amem'
, csMdsk = max x_mdsk inc_adsk
, csMcpu = max x_mcpu inc_acpu
, csImem = x_imem + inc_imem
, csIdsk = x_idsk + inc_idsk
, csIcpu = x_icpu + inc_icpu
, csTmem = x_tmem + Node.tMem node
, csTdsk = x_tdsk + Node.tDsk node
, csTcpu = x_tcpu + Node.tCpu node
, csVcpu = x_vcpu + inc_vcpu
, csXmem = x_xmem + Node.xMem node
, csNmem = x_nmem + Node.nMem node
, csNinst = x_ninst + length (Node.pList node)
}
totalResources :: Node.List -> CStats
totalResources nl =
let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
in cs { csScore = compCV nl }
computeAllocationDelta :: CStats -> CStats -> AllocStats
computeAllocationDelta cini cfin =
let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu} = cini
CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
csTmem = t_mem, csTdsk = t_dsk, csVcpu = v_cpu } = cfin
rini = RSpec i_icpu i_imem i_idsk
rfin = RSpec (f_icpu i_icpu) (f_imem i_imem) (f_idsk i_idsk)
un_cpu = v_cpu f_icpu
runa = RSpec un_cpu (truncate t_mem f_imem) (truncate t_dsk f_idsk)
in (rini, rfin, runa)
detailedCVInfo :: [(Double, String)]
detailedCVInfo = [ (1, "free_mem_cv")
, (1, "free_disk_cv")
, (1, "n1_cnt")
, (1, "reserved_mem_cv")
, (4, "offline_all_cnt")
, (16, "offline_pri_cnt")
, (1, "vcpu_ratio_cv")
, (1, "cpu_load_cv")
, (1, "mem_load_cv")
, (1, "disk_load_cv")
, (1, "net_load_cv")
, (2, "pri_tags_score")
]
detailedCVWeights :: [Double]
detailedCVWeights = map fst detailedCVInfo
compDetailedCV :: Node.List -> [Double]
compDetailedCV nl =
let
all_nodes = Container.elems nl
(offline, nodes) = partition Node.offline all_nodes
mem_l = map Node.pMem nodes
dsk_l = map Node.pDsk nodes
mem_cv = stdDev mem_l
dsk_cv = stdDev dsk_l
n1_score = fromIntegral . sum . map (\n -> length (Node.sList n) +
length (Node.pList n)) .
filter Node.failN1 $ nodes :: Double
res_l = map Node.pRem nodes
res_cv = stdDev res_l
offline_ipri = sum . map (length . Node.pList) $ offline
offline_isec = sum . map (length . Node.sList) $ offline
off_score = fromIntegral (offline_ipri + offline_isec)::Double
off_pri_score = fromIntegral offline_ipri::Double
cpu_l = map Node.pCpu nodes
cpu_cv = stdDev cpu_l
(c_load, m_load, d_load, n_load) = unzip4 $
map (\n ->
let DynUtil c1 m1 d1 n1 = Node.utilLoad n
DynUtil c2 m2 d2 n2 = Node.utilPool n
in (c1/c2, m1/m2, d1/d2, n1/n2)
) nodes
pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
pri_tags_score = fromIntegral pri_tags_inst::Double
in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
, stdDev c_load, stdDev m_load , stdDev d_load, stdDev n_load
, pri_tags_score ]
compCV :: Node.List -> Double
compCV = sum . zipWith (*) detailedCVWeights . compDetailedCV
getOnline :: Node.List -> [Node.Node]
getOnline = filter (not . Node.offline) . Container.elems
compareTables :: Table -> Table -> Table
compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
if a_cv > b_cv then b else a
applyMove :: Node.List -> Instance.Instance
-> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
applyMove nl inst Failover =
let old_pdx = Instance.pNode inst
old_sdx = Instance.sNode inst
old_p = Container.find old_pdx nl
old_s = Container.find old_sdx nl
int_p = Node.removePri old_p inst
int_s = Node.removeSec old_s inst
force_p = Node.offline old_p
new_nl = do
new_p <- Node.addPriEx force_p int_s inst
new_s <- Node.addSec int_p inst old_sdx
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
applyMove nl inst (ReplacePrimary new_pdx) =
let old_pdx = Instance.pNode inst
old_sdx = Instance.sNode inst
old_p = Container.find old_pdx nl
old_s = Container.find old_sdx nl
tgt_n = Container.find new_pdx nl
int_p = Node.removePri old_p inst
int_s = Node.removeSec old_s inst
force_p = Node.offline old_p
new_nl = do
tmp_s <- Node.addPriEx force_p int_s inst
let tmp_s' = Node.removePri tmp_s inst
new_p <- Node.addPriEx force_p tgt_n inst
new_s <- Node.addSecEx force_p tmp_s' inst new_pdx
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
applyMove nl inst (ReplaceSecondary new_sdx) =
let old_pdx = Instance.pNode inst
old_sdx = Instance.sNode inst
old_s = Container.find old_sdx nl
tgt_n = Container.find new_sdx nl
int_s = Node.removeSec old_s inst
force_s = Node.offline old_s
new_inst = Instance.setSec inst new_sdx
new_nl = Node.addSecEx force_s tgt_n inst old_pdx >>=
\new_s -> return (Container.addTwo new_sdx
new_s old_sdx int_s nl,
new_inst, old_pdx, new_sdx)
in new_nl
applyMove nl inst (ReplaceAndFailover new_pdx) =
let old_pdx = Instance.pNode inst
old_sdx = Instance.sNode inst
old_p = Container.find old_pdx nl
old_s = Container.find old_sdx nl
tgt_n = Container.find new_pdx nl
int_p = Node.removePri old_p inst
int_s = Node.removeSec old_s inst
force_s = Node.offline old_s
new_nl = do
new_p <- Node.addPri tgt_n inst
new_s <- Node.addSecEx force_s int_p inst new_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
applyMove nl inst (FailoverAndReplace new_sdx) =
let old_pdx = Instance.pNode inst
old_sdx = Instance.sNode inst
old_p = Container.find old_pdx nl
old_s = Container.find old_sdx nl
tgt_n = Container.find new_sdx nl
int_p = Node.removePri old_p inst
int_s = Node.removeSec old_s inst
force_p = Node.offline old_p
new_nl = do
new_p <- Node.addPriEx force_p int_s inst
new_s <- Node.addSecEx force_p tgt_n inst old_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
allocateOnSingle :: Node.List -> Instance.Instance -> Ndx
-> OpResult Node.AllocElement
allocateOnSingle nl inst new_pdx =
let p = Container.find new_pdx nl
new_inst = Instance.setBoth inst new_pdx Node.noSecondary
in Node.addPri p inst >>= \new_p -> do
let new_nl = Container.add new_pdx new_p nl
new_score = compCV nl
return (new_nl, new_inst, [new_p], new_score)
allocateOnPair :: Node.List -> Instance.Instance -> Ndx -> Ndx
-> OpResult Node.AllocElement
allocateOnPair nl inst new_pdx new_sdx =
let tgt_p = Container.find new_pdx nl
tgt_s = Container.find new_sdx nl
in do
new_p <- Node.addPri tgt_p inst
new_s <- Node.addSec tgt_s inst new_pdx
let new_inst = Instance.setBoth inst new_pdx new_sdx
new_nl = Container.addTwo new_pdx new_p new_sdx new_s nl
return (new_nl, new_inst, [new_p, new_s], compCV new_nl)
checkSingleStep :: Table
-> Instance.Instance
-> Table
-> IMove
-> Table
checkSingleStep ini_tbl target cur_tbl move =
let
Table ini_nl ini_il _ ini_plc = ini_tbl
tmp_resu = applyMove ini_nl target move
in
case tmp_resu of
OpFail _ -> cur_tbl
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
upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
in
compareTables cur_tbl upd_tbl
possibleMoves :: Bool
-> Ndx
-> [IMove]
possibleMoves True tdx =
[ReplaceSecondary tdx,
ReplaceAndFailover tdx,
ReplacePrimary tdx,
FailoverAndReplace tdx]
possibleMoves False tdx =
[ReplaceSecondary tdx,
ReplaceAndFailover tdx]
checkInstanceMove :: [Ndx]
-> Bool
-> Table
-> Instance.Instance
-> Table
checkInstanceMove nodes_idx disk_moves ini_tbl target =
let
opdx = Instance.pNode target
osdx = Instance.sNode target
nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
use_secondary = elem osdx nodes_idx
aft_failover = if use_secondary
then checkSingleStep ini_tbl target ini_tbl Failover
else ini_tbl
all_moves = if disk_moves
then concatMap (possibleMoves use_secondary) nodes
else []
in
foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
checkMove :: [Ndx]
-> Bool
-> Table
-> [Instance.Instance]
-> Table
checkMove nodes_idx disk_moves ini_tbl victims =
let Table _ _ _ ini_plc = ini_tbl
tables = parMap rwhnf (checkInstanceMove nodes_idx disk_moves ini_tbl)
victims
best_tbl =
foldl'
(\ step_tbl new_tbl -> compareTables step_tbl new_tbl)
ini_tbl tables
Table _ _ _ best_plc = best_tbl
in if length best_plc == length ini_plc
then ini_tbl
else best_tbl
doNextBalance :: Table
-> Int
-> Score
-> Bool
doNextBalance ini_tbl max_rounds min_score =
let Table _ _ ini_cv ini_plc = ini_tbl
ini_plc_len = length ini_plc
in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
tryBalance :: Table
-> Bool
-> Bool
-> Score
-> Score
-> Maybe Table
tryBalance ini_tbl disk_moves evac_mode mg_limit min_gain =
let Table ini_nl ini_il ini_cv _ = ini_tbl
all_inst = Container.elems ini_il
all_inst' = if evac_mode
then let bad_nodes = map Node.idx . filter Node.offline $
Container.elems ini_nl
in filter (\e -> Instance.sNode e `elem` bad_nodes ||
Instance.pNode e `elem` bad_nodes)
all_inst
else all_inst
reloc_inst = filter Instance.movable all_inst'
node_idx = map Node.idx . filter (not . Node.offline) $
Container.elems ini_nl
fin_tbl = checkMove node_idx disk_moves ini_tbl reloc_inst
(Table _ _ fin_cv _) = fin_tbl
in
if fin_cv < ini_cv && (ini_cv > mg_limit || ini_cv fin_cv >= min_gain)
then Just fin_tbl
else Nothing
collapseFailures :: [FailMode] -> FailStats
collapseFailures flst =
map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
concatAllocs as (OpGood ns@(_, _, _, nscore)) =
let
cntok = asAllocs as
osols = asSolutions as
nsols = case osols of
[] -> [ns]
(_, _, _, oscore):[] ->
if oscore < nscore
then osols
else [ns]
xs -> ns:xs
nsuc = cntok + 1
in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolutions = nsols }
sumAllocs :: AllocSolution -> AllocSolution -> AllocSolution
sumAllocs (AllocSolution af aa as al) (AllocSolution bf ba bs bl) =
AllocSolution (af ++ bf) (aa + ba) (as ++ bs) (al ++ bl)
describeSolution :: AllocSolution -> String
describeSolution as =
let fcnt = asFailures as
sols = asSolutions as
freasons =
intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
filter ((> 0) . snd) . collapseFailures $ fcnt
in if null sols
then "No valid allocation solutions, failure reasons: " ++
(if null fcnt
then "unknown reasons"
else freasons)
else let (_, _, nodes, cv) = head sols
in printf ("score: %.8f, successes %d, failures %d (%s)" ++
" for node(s) %s") cv (asAllocs as) (length fcnt) freasons
(intercalate "/" . map Node.name $ nodes)
annotateSolution :: AllocSolution -> AllocSolution
annotateSolution as = as { asLog = describeSolution as : asLog as }
genAllocNodes :: Group.List
-> Node.List
-> Int
-> Bool
-> Result AllocNodes
genAllocNodes gl nl count drop_unalloc =
let filter_fn = if drop_unalloc
then filter ((/=) AllocUnallocable . Group.allocPolicy .
flip Container.find gl . Node.group)
else id
all_nodes = filter_fn $ getOnline nl
all_pairs = liftM2 (,) all_nodes all_nodes
ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y &&
Node.group x == Node.group y) all_pairs
in case count of
1 -> Ok (Left (map Node.idx all_nodes))
2 -> Ok (Right (map (\(p, s) -> (Node.idx p, Node.idx s)) ok_pairs))
_ -> Bad "Unsupported number of nodes, only one or two supported"
tryAlloc :: (Monad m) =>
Node.List
-> Instance.List
-> Instance.Instance
-> AllocNodes
-> m AllocSolution
tryAlloc nl _ inst (Right ok_pairs) =
let sols = foldl' (\cstate (p, s) ->
concatAllocs cstate $ allocateOnPair nl inst p s
) emptySolution ok_pairs
in if null ok_pairs
then fail "Not enough online nodes"
else return $ annotateSolution sols
tryAlloc nl _ inst (Left all_nodes) =
let sols = foldl' (\cstate ->
concatAllocs cstate . allocateOnSingle nl inst
) emptySolution all_nodes
in if null all_nodes
then fail "No online nodes"
else return $ annotateSolution sols
solutionDescription :: Group.List -> (Gdx, Result AllocSolution) -> [String]
solutionDescription gl (groupId, result) =
case result of
Ok solution -> map (printf "Group %s (%s): %s" gname pol) (asLog solution)
Bad message -> [printf "Group %s: error %s" gname message]
where grp = Container.find groupId gl
gname = Group.name grp
pol = apolToString (Group.allocPolicy grp)
filterMGResults :: Group.List
-> [(Gdx, Result AllocSolution)]
-> [(Gdx, AllocSolution)]
filterMGResults gl=
filter ((/= AllocUnallocable) . Group.allocPolicy .
flip Container.find gl . fst) .
filter (not . null . asSolutions . snd) .
map (\(y, Ok x) -> (y, x)) .
filter (isOk . snd)
sortMGResults :: Group.List
-> [(Gdx, AllocSolution)]
-> [(Gdx, AllocSolution)]
sortMGResults gl sols =
let extractScore = \(_, _, _, x) -> x
solScore (gdx, sol) = (Group.allocPolicy (Container.find gdx gl),
(extractScore . head . asSolutions) sol)
in sortBy (comparing solScore) sols
tryMGAlloc :: Group.List
-> Node.List
-> Instance.List
-> Instance.Instance
-> Int
-> Result AllocSolution
tryMGAlloc mggl mgnl mgil inst cnt =
let groups = splitCluster mgnl mgil
sols = map (\(gid, (nl, il)) ->
(gid, genAllocNodes mggl nl cnt False >>=
tryAlloc nl il inst))
groups::[(Gdx, Result AllocSolution)]
all_msgs = concatMap (solutionDescription mggl) sols
goodSols = filterMGResults mggl sols
sortedSols = sortMGResults mggl goodSols
in if null sortedSols
then Bad $ intercalate ", " all_msgs
else let (final_group, final_sol) = head sortedSols
final_name = Group.name $ Container.find final_group mggl
selmsg = "Selected group: " ++ final_name
in Ok $ final_sol { asLog = selmsg:all_msgs }
tryReloc :: (Monad m) =>
Node.List
-> Instance.List
-> Idx
-> Int
-> [Ndx]
-> m AllocSolution
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 = foldl' (\cstate x ->
let em = do
(mnl, i, _, _) <-
applyMove nl inst (ReplaceSecondary x)
return (mnl, i, [Container.find x mnl],
compCV mnl)
in concatAllocs cstate em
) emptySolution valid_idxes
in return sols1
tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
\destinations required (" ++ show reqn ++
"), only one supported"
tryMGReloc :: (Monad m) =>
Group.List
-> Node.List
-> Instance.List
-> Idx
-> Int
-> [Ndx]
-> m AllocSolution
tryMGReloc _ mgnl mgil xid ncount ex_ndx = do
let groups = splitCluster mgnl mgil
inst = Container.find xid mgil
(nl, il) <- case lookup (instancePriGroup mgnl inst) groups of
Nothing -> fail $ "Cannot find group for instance " ++
Instance.name inst
Just v -> return v
tryReloc nl il xid ncount ex_ndx
evacInstance :: (Monad m) =>
[Ndx]
-> Instance.List
-> (Node.List, AllocSolution)
-> Idx
-> m (Node.List, AllocSolution)
evacInstance ex_ndx il (nl, old_as) idx = do
new_as <- tryReloc nl il idx 1 ex_ndx
case asSolutions new_as of
csol@(nl', _, _, _):_ ->
return (nl', new_as { asSolutions = csol:asSolutions old_as })
_ -> fail $ "Can't evacuate instance " ++
Instance.name (Container.find idx il) ++
": " ++ describeSolution new_as
tryEvac :: (Monad m) =>
Node.List
-> Instance.List
-> [Idx]
-> [Ndx]
-> m AllocSolution
tryEvac nl il idxs ex_ndx = do
(_, sol) <- foldM (evacInstance ex_ndx il) (nl, emptySolution) idxs
return sol
tryMGEvac :: (Monad m) =>
Group.List
-> Node.List
-> Instance.List
-> [Ndx]
-> m AllocSolution
tryMGEvac _ nl il ex_ndx =
let ex_nodes = map (`Container.find` nl) ex_ndx
all_insts = nub . concatMap Node.sList $ ex_nodes
gni = splitCluster nl il
all_insts' = map (\idx ->
(instancePriGroup nl (Container.find idx il),
idx)) all_insts
all_insts'' = groupBy ((==) `on` fst) all_insts'
all_insts3 = map (\xs -> let (gdxs, idxs) = unzip xs
in (head gdxs, idxs)) all_insts''
in do
all_insts4 <-
mapM (\(gdx, idxs) -> do
case lookup gdx gni of
Nothing -> fail $ "Can't find group index " ++ show gdx
Just (gnl, gil) -> return (gdx, gnl, gil, idxs))
all_insts3
results <- mapM (\(_, gnl, gil, idxs) -> tryEvac gnl gil idxs ex_ndx)
all_insts4
let sol = foldl' (\orig_sol group_sol ->
sumAllocs orig_sol group_sol) emptySolution results
return $ annotateSolution sol
iterateAlloc :: Node.List
-> Instance.List
-> Instance.Instance
-> AllocNodes
-> [Instance.Instance]
-> [CStats]
-> Result AllocResult
iterateAlloc nl il newinst allocnodes ixes cstats =
let depth = length ixes
newname = printf "new-%d" depth::String
newidx = length (Container.elems il) + depth
newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
in case tryAlloc nl il newi2 allocnodes of
Bad s -> Bad s
Ok (AllocSolution { asFailures = errs, asSolutions = sols3 }) ->
case sols3 of
[] -> Ok (collapseFailures errs, nl, il, ixes, cstats)
(xnl, xi, _, _):[] ->
iterateAlloc xnl (Container.add newidx xi il)
newinst allocnodes (xi:ixes)
(totalResources xnl:cstats)
_ -> Bad "Internal error: multiple solutions for single\
\ allocation"
tieredAlloc :: Node.List
-> Instance.List
-> Instance.Instance
-> AllocNodes
-> [Instance.Instance]
-> [CStats]
-> Result AllocResult
tieredAlloc nl il newinst allocnodes ixes cstats =
case iterateAlloc nl il newinst allocnodes ixes cstats of
Bad s -> Bad s
Ok (errs, nl', il', ixes', cstats') ->
case Instance.shrinkByType newinst . fst . last $
sortBy (comparing snd) errs of
Bad _ -> Ok (errs, nl', il', ixes', cstats')
Ok newinst' ->
tieredAlloc nl' il' newinst' allocnodes ixes' cstats'
tieredSpecMap :: [Instance.Instance]
-> [String]
tieredSpecMap trl_ixes =
let fin_trl_ixes = reverse trl_ixes
ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes
spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs))
ix_byspec
in map (\(spec, cnt) -> printf "%d,%d,%d=%d" (rspecMem spec)
(rspecDsk spec) (rspecCpu spec) cnt) spec_map
computeMoves :: Instance.Instance
-> String
-> IMove
-> String
-> String
-> (String, [String])
computeMoves i inam mv c d =
case mv of
Failover -> ("f", [mig])
FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
where morf = if Instance.running i then "migrate" else "failover"
mig = printf "%s -f %s" morf inam::String
rep n = printf "replace-disks -n %s %s" n inam
printSolutionLine :: Node.List
-> Instance.List
-> Int
-> Int
-> Placement
-> Int
-> (String, [String])
printSolutionLine nl il nmlen imlen plc pos =
let
pmlen = (2*nmlen + 1)
(i, p, s, mv, c) = plc
inst = Container.find i il
inam = Instance.alias inst
npri = Node.alias $ Container.find p nl
nsec = Node.alias $ Container.find s nl
opri = Node.alias $ Container.find (Instance.pNode inst) nl
osec = Node.alias $ Container.find (Instance.sNode inst) nl
(moves, cmds) = computeMoves inst inam mv npri nsec
ostr = printf "%s:%s" opri osec::String
nstr = printf "%s:%s" npri nsec::String
in
(printf " %3d. %-*s %-*s => %-*s %.8f a=%s"
pos imlen inam pmlen ostr
pmlen nstr c moves,
cmds)
involvedNodes :: Instance.List -> Placement -> [Ndx]
involvedNodes il plc =
let (i, np, ns, _, _) = plc
inst = Container.find i il
op = Instance.pNode inst
os = Instance.sNode inst
in nub [np, ns, op, os]
mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
| null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
| otherwise = ([n]:cjs, ndx)
splitJobs :: [MoveJob] -> [JobSet]
splitJobs = fst . foldl mergeJobs ([], [])
formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
formatJob jsn jsl (sn, (_, _, _, cmds)) =
let out =
printf " echo job %d/%d" jsn sn:
printf " check":
map (" gnt-instance " ++) cmds
in if sn == 1
then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
else out
formatCmds :: [JobSet] -> String
formatCmds =
unlines .
concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
(zip [1..] js)) .
zip [1..]
printNodes :: Node.List -> [String] -> String
printNodes nl fs =
let fields = case fs of
[] -> Node.defaultFields
"+":rest -> Node.defaultFields ++ rest
_ -> fs
snl = sortBy (comparing Node.idx) (Container.elems nl)
(header, isnum) = unzip $ map Node.showHeader fields
in unlines . map ((:) ' ' . intercalate " ") $
formatTable (header:map (Node.list fields) snl) isnum
printInsts :: Node.List -> Instance.List -> String
printInsts nl il =
let sil = sortBy (comparing Instance.idx) (Container.elems il)
helper inst = [ if Instance.running inst then "R" else " "
, Instance.name inst
, Container.nameOf nl (Instance.pNode inst)
, let sdx = Instance.sNode inst
in if sdx == Node.noSecondary
then ""
else Container.nameOf nl sdx
, printf "%3d" $ Instance.vcpus inst
, printf "%5d" $ Instance.mem inst
, printf "%5d" $ Instance.dsk inst `div` 1024
, printf "%5.3f" lC
, printf "%5.3f" lM
, printf "%5.3f" lD
, printf "%5.3f" lN
]
where DynUtil lC lM lD lN = Instance.util inst
header = [ "F", "Name", "Pri_node", "Sec_node", "vcpu", "mem"
, "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
isnum = False:False:False:False:repeat True
in unlines . map ((:) ' ' . intercalate " ") $
formatTable (header:map helper sil) isnum
printStats :: Node.List -> String
printStats nl =
let dcvs = compDetailedCV nl
(weights, names) = unzip detailedCVInfo
hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
formatted = map (\(w, header, val) ->
printf "%s=%.8f(x%.2f)" header val w::String) hd
in intercalate ", " formatted
iMoveToJob :: Node.List -> Instance.List
-> Idx -> IMove -> [OpCodes.OpCode]
iMoveToJob nl il idx move =
let inst = Container.find idx il
iname = Instance.name inst
lookNode = Just . Container.nameOf nl
opF = if Instance.running inst
then OpCodes.OpMigrateInstance iname True False
else OpCodes.OpFailoverInstance iname False
opR n = OpCodes.OpReplaceDisks iname (lookNode n)
OpCodes.ReplaceNewSecondary [] Nothing
in case move of
Failover -> [ opF ]
ReplacePrimary np -> [ opF, opR np, opF ]
ReplaceSecondary ns -> [ opR ns ]
ReplaceAndFailover np -> [ opR np, opF ]
FailoverAndReplace ns -> [ opF, opR ns ]
instanceGroup :: Node.List -> Instance.Instance -> Result Gdx
instanceGroup nl i =
let sidx = Instance.sNode i
pnode = Container.find (Instance.pNode i) nl
snode = if sidx == Node.noSecondary
then pnode
else Container.find sidx nl
pgroup = Node.group pnode
sgroup = Node.group snode
in if pgroup /= sgroup
then fail ("Instance placed accross two node groups, primary " ++
show pgroup ++ ", secondary " ++ show sgroup)
else return pgroup
instancePriGroup :: Node.List -> Instance.Instance -> Gdx
instancePriGroup nl i =
let pnode = Container.find (Instance.pNode i) nl
in Node.group pnode
findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
findSplitInstances nl il =
filter (not . isOk . instanceGroup nl) (Container.elems il)
splitCluster :: Node.List -> Instance.List ->
[(Gdx, (Node.List, Instance.List))]
splitCluster nl il =
let ngroups = Node.computeGroups (Container.elems nl)
in map (\(guuid, nodes) ->
let nidxs = map Node.idx nodes
nodes' = zip nidxs nodes
instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
in (guuid, (Container.fromList nodes', instances))) ngroups