module Ganeti.HTools.Cluster
(
AllocSolution
, Table(..)
, CStats(..)
, AllocStats
, totalResources
, computeAllocationDelta
, computeBadItems
, printSolution
, printSolutionLine
, formatCmds
, involvedNodes
, splitJobs
, printNodes
, printInsts
, checkMove
, doNextBalance
, tryBalance
, compCV
, printStats
, iMoveToJob
, tryAlloc
, tryReloc
, tryEvac
, collapseFailures
) where
import Data.List
import Data.Ord (comparing)
import Text.Printf (printf)
import Control.Monad
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
import Ganeti.HTools.Types
import Ganeti.HTools.Utils
import qualified Ganeti.OpCodes as OpCodes
type AllocSolution = ([FailMode], Int, [(Score, Node.AllocElement)])
data Table = Table Node.List Instance.List Score [Placement]
deriving (Show)
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
}
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
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
, csMmem = max x_mmem inc_amem'
, csMdsk = max x_mdsk inc_adsk
, csMcpu = x_mcpu
, 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 = if inc_vcpu == Node.noLimitInt
then Node.noLimitInt
else 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 f_imem f_idsk
un_cpu = if v_cpu == Node.noLimitInt
then Node.noLimitInt
else v_cpu f_icpu
runa = RSpec un_cpu (truncate t_mem f_imem) (truncate t_dsk f_idsk)
in (rini, rfin, runa)
detailedCVNames :: [String]
detailedCVNames = [ "free_mem_cv"
, "free_disk_cv"
, "n1_cnt"
, "reserved_mem_cv"
, "offline_all_cnt"
, "offline_pri_cnt"
, "vcpu_ratio_cv"
, "cpu_load_cv"
, "mem_load_cv"
, "disk_load_cv"
, "net_load_cv"
, "pri_tags_score"
]
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 = varianceCoeff mem_l
dsk_cv = varianceCoeff dsk_l
n1_l = length $ filter Node.failN1 nodes
n1_score = fromIntegral n1_l::Double
res_l = map Node.pRem nodes
res_cv = varianceCoeff 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 = varianceCoeff 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
, varianceCoeff c_load, varianceCoeff m_load
, varianceCoeff d_load, varianceCoeff n_load
, pri_tags_score ]
compCV :: Node.List -> Double
compCV = sum . 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
new_nl = do
new_p <- Node.addPri 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
new_nl = do
tmp_s <- Node.addPri int_s inst
let tmp_s' = Node.removePri tmp_s inst
new_p <- Node.addPri tgt_n inst
new_s <- Node.addSec 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
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,
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
new_nl = do
new_p <- Node.addPri tgt_n inst
new_s <- Node.addSec 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
new_nl = do
new_p <- Node.addPri int_s inst
new_s <- Node.addSec 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 -> Node.Node
-> OpResult Node.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, new_inst, [new_p])
in new_nl
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
-> OpResult Node.AllocElement
allocateOnPair nl inst tgt_p tgt_s =
let new_pdx = Node.idx tgt_p
new_sdx = Node.idx tgt_s
new_nl = 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
return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
[new_p, new_s])
in 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
best_tbl =
foldl'
(\ step_tbl em ->
compareTables step_tbl $
checkInstanceMove nodes_idx disk_moves ini_tbl em)
ini_tbl victims
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
-> Maybe Table
tryBalance ini_tbl disk_moves evac_mode =
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
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 (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
let nscore = compCV nl
nsols = case osols of
[] -> [(nscore, ns)]
(oscore, _):[] ->
if oscore < nscore
then osols
else [(nscore, ns)]
xs -> (nscore, ns):xs
nsuc = cntok + 1
in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
tryAlloc :: (Monad m) =>
Node.List
-> Instance.List
-> Instance.Instance
-> Int
-> m AllocSolution
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 = foldl' (\cstate (p, s) ->
concatAllocs cstate $ allocateOnPair nl inst p s
) ([], 0, []) ok_pairs
in return sols
tryAlloc nl _ inst 1 =
let all_nodes = getOnline nl
sols = foldl' (\cstate ->
concatAllocs cstate . allocateOnSingle nl inst
) ([], 0, []) all_nodes
in return sols
tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
\destinations required (" ++ show reqn ++
"), only two supported"
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])
in concatAllocs cstate em
) ([], 0, []) valid_idxes
in return sols1
tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
\destinations required (" ++ show reqn ++
"), only one supported"
tryEvac :: (Monad m) =>
Node.List
-> Instance.List
-> [Ndx]
-> m AllocSolution
tryEvac nl il ex_ndx =
let ex_nodes = map (`Container.find` nl) ex_ndx
all_insts = nub . concatMap Node.sList $ ex_nodes
in do
(_, sol) <- foldM (\(nl', (_, _, rsols)) idx -> do
(fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
case aes of
csol@(_, (nl'', _, _)):_ ->
return (nl'', (fm, cs, csol:rsols))
_ -> fail $ "Can't evacuate instance " ++
show idx
) (nl, ([], 0, [])) all_insts
return sol
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.name inst
npri = Container.nameOf nl p
nsec = Container.nameOf nl s
opri = Container.nameOf nl $ Instance.pNode inst
osec = Container.nameOf nl $ Instance.sNode inst
(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..]
printSolution :: Node.List
-> Instance.List
-> [Placement]
-> ([String], [[String]])
printSolution nl il sol =
let
nmlen = Container.maxNameLen nl
imlen = Container.maxNameLen il
in
unzip $ zipWith (printSolutionLine nl il nmlen imlen) sol [1..]
printNodes :: Node.List -> [String] -> String
printNodes nl fs =
let fields = if null fs
then Node.defaultFields
else 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
hd = zip (detailedCVNames ++ repeat "unknown") dcvs
formatted = map (\(header, val) ->
printf "%s=%.8f" header val::String) hd
in intercalate ", " formatted
iMoveToJob :: String -> Node.List -> Instance.List
-> Idx -> IMove -> [OpCodes.OpCode]
iMoveToJob csf nl il idx move =
let inst = Container.find idx il
iname = Instance.name inst ++ csf
lookNode n = Just (Container.nameOf nl n ++ csf)
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 ]