module Ganeti.HTools.Cluster
(
AllocDetails(..)
, AllocSolution(..)
, EvacSolution(..)
, Table(..)
, CStats(..)
, AllocNodes
, AllocResult
, AllocMethod
, AllocSolutionList
, totalResources
, computeAllocationDelta
, computeBadItems
, printSolutionLine
, formatCmds
, involvedNodes
, getMoves
, splitJobs
, printNodes
, printInsts
, doNextBalance
, tryBalance
, compCV
, compCVNodes
, compDetailedCV
, printStats
, iMoveToJob
, genAllocNodes
, tryAlloc
, tryGroupAlloc
, tryMGAlloc
, tryNodeEvac
, tryChangeGroup
, collapseFailures
, allocList
, iterateAlloc
, tieredAlloc
, instanceGroup
, findSplitInstances
, splitCluster
) where
import Control.Applicative ((<$>), liftA2)
import Control.Arrow ((&&&))
import Control.Monad (unless)
import qualified Data.IntSet as IntSet
import Data.List
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
import Data.Ord (comparing)
import Text.Printf (printf)
import Ganeti.BasicTypes
import Ganeti.HTools.AlgorithmParams (AlgorithmOptions(..), defaultOptions)
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Nic as Nic
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Group as Group
import Ganeti.HTools.Types
import Ganeti.Compat
import qualified Ganeti.OpCodes as OpCodes
import Ganeti.Utils
import Ganeti.Utils.Statistics
import Ganeti.Types (EvacMode(..), mkNonEmpty)
data AllocDetails = AllocDetails Int (Maybe String)
deriving (Show)
data AllocSolution = AllocSolution
{ asFailures :: [FailMode]
, asAllocs :: Int
, asSolution :: Maybe Node.AllocElement
, asLog :: [String]
}
data EvacSolution = EvacSolution
{ esMoved :: [(Idx, Gdx, [Ndx])]
, esFailed :: [(Idx, String)]
, esOpCodes :: [[OpCodes.OpCode]]
} deriving (Show)
type AllocResult = (FailStats, Node.List, Instance.List,
[Instance.Instance], [CStats])
type AllocSolutionList = [(Instance.Instance, AllocSolution)]
type AllocNodes = Either [Ndx] [(Ndx, [Ndx])]
emptyAllocSolution :: AllocSolution
emptyAllocSolution = AllocSolution { asFailures = [], asAllocs = 0
, asSolution = Nothing, asLog = [] }
emptyEvacSolution :: EvacSolution
emptyEvacSolution = EvacSolution { esMoved = []
, esFailed = []
, esOpCodes = []
}
data Table = Table Node.List Instance.List Score [Placement]
deriving (Show)
data CStats = CStats
{ csFmem :: Integer
, csFdsk :: Integer
, csFspn :: Integer
, csAmem :: Integer
, csAdsk :: Integer
, csAcpu :: Integer
, csMmem :: Integer
, csMdsk :: Integer
, csMcpu :: Integer
, csImem :: Integer
, csIdsk :: Integer
, csIspn :: Integer
, csIcpu :: Integer
, csTmem :: Double
, csTdsk :: Double
, csTspn :: Double
, csTcpu :: Double
, csVcpu :: Integer
, csNcpu :: Double
, csXmem :: Integer
, csNmem :: Integer
, csScore :: Score
, csNinst :: Int
} deriving (Show)
type AllocMethod = Node.List
-> Instance.List
-> Maybe Int
-> Instance.Instance
-> AllocNodes
-> [Instance.Instance]
-> [CStats]
-> Result AllocResult
type EvacInnerState =
Either String (Node.List, Instance.Instance, Score, Ndx)
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)
instanceNodes :: Node.List -> Instance.Instance ->
(Ndx, Ndx, Node.Node, Node.Node)
instanceNodes nl inst =
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
in (old_pdx, old_sdx, old_p, old_s)
emptyCStats :: CStats
emptyCStats = CStats 0 0 0 0 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, csNcpu = x_ncpu,
csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst,
csFspn = x_fspn, csIspn = x_ispn, csTspn = x_tspn
}
= 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_ispn = Node.tSpindles node Node.fSpindles node
inc_vcpu = Node.hiCpu node
inc_acpu = Node.availCpu node
inc_ncpu = fromIntegral (Node.uCpu node) /
iPolicyVcpuRatio (Node.iPolicy node)
in cs { csFmem = x_fmem + fromIntegral (Node.fMem node)
, csFdsk = x_fdsk + fromIntegral (Node.fDsk node)
, csFspn = x_fspn + fromIntegral (Node.fSpindles node)
, csAmem = x_amem + fromIntegral inc_amem'
, csAdsk = x_adsk + fromIntegral inc_adsk
, csAcpu = x_acpu + fromIntegral inc_acpu
, csMmem = max x_mmem (fromIntegral inc_amem')
, csMdsk = max x_mdsk (fromIntegral inc_adsk)
, csMcpu = max x_mcpu (fromIntegral inc_acpu)
, csImem = x_imem + fromIntegral inc_imem
, csIdsk = x_idsk + fromIntegral inc_idsk
, csIspn = x_ispn + fromIntegral inc_ispn
, csIcpu = x_icpu + fromIntegral inc_icpu
, csTmem = x_tmem + Node.tMem node
, csTdsk = x_tdsk + Node.tDsk node
, csTspn = x_tspn + fromIntegral (Node.tSpindles node)
, csTcpu = x_tcpu + Node.tCpu node
, csVcpu = x_vcpu + fromIntegral inc_vcpu
, csNcpu = x_ncpu + inc_ncpu
, csXmem = x_xmem + fromIntegral (Node.xMem node)
, csNmem = x_nmem + fromIntegral (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,
csNcpu = i_ncpu, csIspn = i_ispn } = cini
CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
csTmem = t_mem, csTdsk = t_dsk, csVcpu = f_vcpu,
csNcpu = f_ncpu, csTcpu = f_tcpu,
csIspn = f_ispn, csTspn = t_spn } = cfin
rini = AllocInfo { allocInfoVCpus = fromIntegral i_icpu
, allocInfoNCpus = i_ncpu
, allocInfoMem = fromIntegral i_imem
, allocInfoDisk = fromIntegral i_idsk
, allocInfoSpn = fromIntegral i_ispn
}
rfin = AllocInfo { allocInfoVCpus = fromIntegral (f_icpu i_icpu)
, allocInfoNCpus = f_ncpu i_ncpu
, allocInfoMem = fromIntegral (f_imem i_imem)
, allocInfoDisk = fromIntegral (f_idsk i_idsk)
, allocInfoSpn = fromIntegral (f_ispn i_ispn)
}
runa = AllocInfo { allocInfoVCpus = fromIntegral (f_vcpu f_icpu)
, allocInfoNCpus = f_tcpu f_ncpu
, allocInfoMem = truncate t_mem fromIntegral f_imem
, allocInfoDisk = truncate t_dsk fromIntegral f_idsk
, allocInfoSpn = truncate t_spn fromIntegral f_ispn
}
in (rini, rfin, runa)
detailedCVInfoExt :: [((Double, String), ([Double] -> Statistics, Bool))]
detailedCVInfoExt = [ ((1, "free_mem_cv"), (getStdDevStatistics, True))
, ((1, "free_disk_cv"), (getStdDevStatistics, True))
, ((1, "n1_cnt"), (getSumStatistics, True))
, ((1, "reserved_mem_cv"), (getStdDevStatistics, True))
, ((4, "offline_all_cnt"), (getSumStatistics, False))
, ((16, "offline_pri_cnt"), (getSumStatistics, False))
, ((1, "vcpu_ratio_cv"), (getStdDevStatistics, True))
, ((1, "cpu_load_cv"), (getStdDevStatistics, True))
, ((1, "mem_load_cv"), (getStdDevStatistics, True))
, ((1, "disk_load_cv"), (getStdDevStatistics, True))
, ((1, "net_load_cv"), (getStdDevStatistics, True))
, ((2, "pri_tags_score"), (getSumStatistics, True))
, ((1, "spindles_cv"), (getStdDevStatistics, True))
]
detailedCVInfo :: [(Double, String)]
detailedCVInfo = map fst detailedCVInfoExt
detailedCVWeights :: [Double]
detailedCVWeights = map fst detailedCVInfo
detailedCVAggregation :: [([Double] -> Statistics, Bool)]
detailedCVAggregation = map snd detailedCVInfoExt
detailedCVOnlineStatus :: [Bool]
detailedCVOnlineStatus = map snd detailedCVAggregation
compDetailedCVNode :: Node.Node -> [Double]
compDetailedCVNode node =
let mem = Node.pMem node
dsk = Node.pDsk node
n1 = fromIntegral
$ if Node.failN1 node
then length (Node.sList node) + length (Node.pList node)
else 0
res = Node.pRem node
ipri = fromIntegral . length $ Node.pList node
isec = fromIntegral . length $ Node.sList node
ioff = ipri + isec
cpu = Node.pCpuEff node
DynUtil c1 m1 d1 nn1 = Node.utilLoad node
DynUtil c2 m2 d2 nn2 = Node.utilPool node
(c_load, m_load, d_load, n_load) = (c1/c2, m1/m2, d1/d2, nn1/nn2)
pri_tags = fromIntegral $ Node.conflictingPrimaries node
spindles = Node.instSpindles node / Node.hiSpindles node
in [ mem, dsk, n1, res, ioff, ipri, cpu
, c_load, m_load, d_load, n_load
, pri_tags, spindles
]
compClusterStatistics :: [Node.Node] -> [Statistics]
compClusterStatistics all_nodes =
let (offline, nodes) = partition Node.offline all_nodes
offline_values = transpose (map compDetailedCVNode offline)
++ repeat []
online_values = transpose $ map compDetailedCVNode nodes
aggregate (f, True) (onNodes, _) = f onNodes
aggregate (f, False) (_, offNodes) = f offNodes
in zipWith aggregate detailedCVAggregation
$ zip online_values offline_values
updateClusterStatistics :: [Statistics]
-> (Node.Node, Node.Node) -> [Statistics]
updateClusterStatistics stats (old, new) =
let update = zip (compDetailedCVNode old) (compDetailedCVNode new)
online = not $ Node.offline old
updateStat forOnline stat upd = if forOnline == online
then updateStatistics stat upd
else stat
in zipWith3 updateStat detailedCVOnlineStatus stats update
updateClusterStatisticsTwice :: [Statistics]
-> (Node.Node, Node.Node)
-> (Node.Node, Node.Node)
-> [Statistics]
updateClusterStatisticsTwice s a =
updateClusterStatistics (updateClusterStatistics s a)
compDetailedCV :: [Node.Node] -> [Double]
compDetailedCV = map getStatisticValue . compClusterStatistics
compCVfromStats :: [Statistics] -> Double
compCVfromStats = sum . zipWith (*) detailedCVWeights . map getStatisticValue
compCVNodes :: [Node.Node] -> Double
compCVNodes = sum . zipWith (*) detailedCVWeights . compDetailedCV
compCV :: Node.List -> Double
compCV = compCVNodes . Container.elems
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
applyMoveEx :: Bool
-> Node.List -> Instance.Instance
-> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
applyMoveEx force nl inst Failover =
let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
int_p = Node.removePri old_p inst
int_s = Node.removeSec old_s inst
new_nl = do
Node.checkMigration old_p old_s
new_p <- Node.addPriEx (Node.offline old_p || force) int_s inst
new_s <- Node.addSecExEx (Node.offline old_p) (Node.offline old_p)
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
applyMoveEx force nl inst (FailoverToAny new_pdx) = do
let (old_pdx, old_sdx, old_pnode, _) = instanceNodes nl inst
new_pnode = Container.find new_pdx nl
force_failover = Node.offline old_pnode || force
Node.checkMigration old_pnode new_pnode
new_pnode' <- Node.addPriEx force_failover new_pnode inst
let old_pnode' = Node.removePri old_pnode inst
inst' = Instance.setPri inst new_pdx
nl' = Container.addTwo old_pdx old_pnode' new_pdx new_pnode' nl
return (nl', inst', new_pdx, old_sdx)
applyMoveEx force nl inst (ReplacePrimary new_pdx) =
let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
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 || force
new_nl = do
Node.checkMigration old_p old_s
Node.checkMigration old_s tgt_n
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
applyMoveEx force 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 || force
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
applyMoveEx force nl inst (ReplaceAndFailover new_pdx) =
let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
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 || force
new_nl = do
Node.checkMigration old_p tgt_n
new_p <- Node.addPriEx force 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
applyMoveEx force nl inst (FailoverAndReplace new_sdx) =
let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
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 || force
new_nl = do
Node.checkMigration old_p old_s
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 :: AlgorithmOptions
-> Node.List -> Instance.Instance -> Ndx
-> OpResult Node.AllocElement
allocateOnSingle opts nl inst new_pdx =
let p = Container.find new_pdx nl
new_inst = Instance.setBoth inst new_pdx Node.noSecondary
force = algIgnoreSoftErrors opts
in do
Instance.instMatchesPolicy inst (Node.iPolicy p) (Node.exclStorage p)
new_p <- Node.addPriEx force p inst
let new_nl = Container.add new_pdx new_p nl
new_score = compCV new_nl
return (new_nl, new_inst, [new_p], new_score)
allocateOnPair :: AlgorithmOptions
-> [Statistics]
-> Node.List -> Instance.Instance -> Ndx -> Ndx
-> OpResult Node.AllocElement
allocateOnPair opts stats nl inst new_pdx new_sdx =
let tgt_p = Container.find new_pdx nl
tgt_s = Container.find new_sdx nl
force = algIgnoreSoftErrors opts
in do
Instance.instMatchesPolicy inst (Node.iPolicy tgt_p)
(Node.exclStorage tgt_p)
new_p <- Node.addPriEx force 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
new_stats = updateClusterStatisticsTwice stats
(tgt_p, new_p) (tgt_s, new_s)
return (new_nl, new_inst, [new_p, new_s], compCVfromStats new_stats)
checkSingleStep :: Bool
-> Table
-> Instance.Instance
-> Table
-> IMove
-> Table
checkSingleStep force ini_tbl target cur_tbl move =
let Table ini_nl ini_il _ ini_plc = ini_tbl
tmp_resu = applyMoveEx force ini_nl target move
in case tmp_resu of
Bad _ -> cur_tbl
Ok (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 :: MirrorType
-> Bool
-> Bool
-> Bool
-> (Bool, Bool)
-> Ndx
-> [IMove]
possibleMoves MirrorNone _ _ _ _ _ = []
possibleMoves MirrorExternal _ False _ _ _ = []
possibleMoves MirrorExternal _ True _ _ tdx =
[ FailoverToAny tdx ]
possibleMoves MirrorInternal _ _ False _ _ = []
possibleMoves MirrorInternal _ False True _ tdx =
[ ReplaceSecondary tdx ]
possibleMoves MirrorInternal _ _ True (True, False) tdx =
[ ReplaceSecondary tdx
]
possibleMoves MirrorInternal True True True (False, _) tdx =
[ ReplaceSecondary tdx
, ReplaceAndFailover tdx
, ReplacePrimary tdx
, FailoverAndReplace tdx
]
possibleMoves MirrorInternal True True True (True, True) tdx =
[ ReplaceSecondary tdx
, ReplaceAndFailover tdx
, FailoverAndReplace tdx
]
possibleMoves MirrorInternal False True True _ tdx =
[ ReplaceSecondary tdx
, ReplaceAndFailover tdx
]
checkInstanceMove :: AlgorithmOptions
-> [Ndx]
-> Table
-> Instance.Instance
-> Table
checkInstanceMove opts nodes_idx ini_tbl@(Table nl _ _ _) target =
let force = algIgnoreSoftErrors opts
disk_moves = algDiskMoves opts
inst_moves = algInstanceMoves opts
rest_mig = algRestrictedMigration opts
opdx = Instance.pNode target
osdx = Instance.sNode target
bad_nodes = [opdx, osdx]
nodes = filter (`notElem` bad_nodes) nodes_idx
mir_type = Instance.mirrorType target
use_secondary = elem osdx nodes_idx && inst_moves
aft_failover = if mir_type == MirrorInternal && use_secondary
then checkSingleStep force ini_tbl target ini_tbl
Failover
else ini_tbl
primary_drained = Node.offline
. flip Container.find nl
$ Instance.pNode target
all_moves = concatMap (possibleMoves mir_type use_secondary inst_moves
disk_moves (rest_mig, primary_drained)) nodes
in
foldl' (checkSingleStep force ini_tbl target) aft_failover all_moves
checkMove :: AlgorithmOptions
-> [Ndx]
-> Table
-> [Instance.Instance]
-> Table
checkMove opts nodes_idx ini_tbl victims =
let Table _ _ _ ini_plc = ini_tbl
tables = parMap rwhnf (checkInstanceMove opts nodes_idx ini_tbl)
victims
best_tbl = foldl' compareTables 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 :: AlgorithmOptions
-> Table
-> Maybe Table
tryBalance opts ini_tbl =
let evac_mode = algEvacMode opts
mg_limit = algMinGainLimit opts
min_gain = algMinGain opts
Table ini_nl ini_il ini_cv _ = ini_tbl
all_inst = Container.elems ini_il
all_nodes = Container.elems ini_nl
(offline_nodes, online_nodes) = partition Node.offline all_nodes
all_inst' = if evac_mode
then let bad_nodes = map Node.idx offline_nodes
in filter (any (`elem` bad_nodes) .
Instance.allNodes) all_inst
else all_inst
reloc_inst = filter (\i -> Instance.movable i &&
Instance.autoBalance i) all_inst'
node_idx = map Node.idx online_nodes
fin_tbl = checkMove opts node_idx 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, foldl' (\a e -> if e == k then a + 1 else a) 0 flst))
[minBound..maxBound]
bestAllocElement :: Maybe Node.AllocElement
-> Maybe Node.AllocElement
-> Maybe Node.AllocElement
bestAllocElement a Nothing = a
bestAllocElement Nothing b = b
bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
if ascore < bscore then a else b
concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
concatAllocs as (Bad reason) = as { asFailures = reason : asFailures as }
concatAllocs as (Ok ns) =
let
cntok = asAllocs as
osols = asSolution as
nsols = bestAllocElement osols (Just ns)
nsuc = cntok + 1
in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolution = nsols }
sumAllocs :: AllocSolution -> AllocSolution -> AllocSolution
sumAllocs (AllocSolution aFails aAllocs aSols aLog)
(AllocSolution bFails bAllocs bSols bLog) =
let nFails = bFails ++ aFails
nAllocs = aAllocs + bAllocs
nSols = bestAllocElement aSols bSols
nLog = bLog ++ aLog
in AllocSolution nFails nAllocs nSols nLog
describeSolution :: AllocSolution -> String
describeSolution as =
let fcnt = asFailures as
sols = asSolution as
freasons =
intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
filter ((> 0) . snd) . collapseFailures $ fcnt
in case sols of
Nothing -> "No valid allocation solutions, failure reasons: " ++
(if null fcnt then "unknown reasons" else freasons)
Just (_, _, nodes, cv) ->
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 }
reverseEvacSolution :: EvacSolution -> EvacSolution
reverseEvacSolution (EvacSolution f m o) =
EvacSolution (reverse f) (reverse m) (reverse o)
genAllocNodes :: Group.List
-> Node.List
-> Int
-> Bool
-> Result AllocNodes
genAllocNodes gl nl count drop_unalloc =
let filter_fn = if drop_unalloc
then filter (Group.isAllocable .
flip Container.find gl . Node.group)
else id
all_nodes = filter_fn $ getOnline nl
all_pairs = [(Node.idx p,
[Node.idx s | s <- all_nodes,
Node.idx p /= Node.idx s,
Node.group p == Node.group s]) |
p <- all_nodes]
in case count of
1 -> Ok (Left (map Node.idx all_nodes))
2 -> Ok (Right (filter (not . null . snd) all_pairs))
_ -> Bad "Unsupported number of nodes, only one or two supported"
tryAlloc :: (Monad m) =>
AlgorithmOptions
-> Node.List
-> Instance.List
-> Instance.Instance
-> AllocNodes
-> m AllocSolution
tryAlloc _ _ _ _ (Right []) = fail "Not enough online nodes"
tryAlloc opts nl _ inst (Right ok_pairs) =
let cstat = compClusterStatistics $ Container.elems nl
psols = parMap rwhnf (\(p, ss) ->
foldl' (\cstate ->
concatAllocs cstate .
allocateOnPair opts cstat nl inst p)
emptyAllocSolution ss) ok_pairs
sols = foldl' sumAllocs emptyAllocSolution psols
in return $ annotateSolution sols
tryAlloc _ _ _ _ (Left []) = fail "No online nodes"
tryAlloc opts nl _ inst (Left all_nodes) =
let sols = foldl' (\cstate ->
concatAllocs cstate . allocateOnSingle opts nl inst
) emptyAllocSolution all_nodes
in return $ annotateSolution sols
solutionDescription :: (Group.Group, Result AllocSolution)
-> [String]
solutionDescription (grp, 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 gname = Group.name grp
pol = allocPolicyToRaw (Group.allocPolicy grp)
filterMGResults :: [(Group.Group, Result AllocSolution)]
-> [(Group.Group, AllocSolution)]
filterMGResults = foldl' fn []
where unallocable = not . Group.isAllocable
fn accu (grp, rasol) =
case rasol of
Bad _ -> accu
Ok sol | isNothing (asSolution sol) -> accu
| unallocable grp -> accu
| otherwise -> (grp, sol):accu
sortMGResults :: [(Group.Group, AllocSolution)]
-> [(Group.Group, AllocSolution)]
sortMGResults sols =
let extractScore (_, _, _, x) = x
solScore (grp, sol) = (Group.allocPolicy grp,
(extractScore . fromJust . asSolution) sol)
in sortBy (comparing solScore) sols
hasRequiredNetworks :: Group.Group -> Instance.Instance -> Bool
hasRequiredNetworks ng = all hasNetwork . Instance.nics
where hasNetwork = maybe True (`elem` Group.networks ng) . Nic.network
filterValidGroups :: [(Group.Group, (Node.List, Instance.List))]
-> Instance.Instance
-> ([(Group.Group, (Node.List, Instance.List))], [String])
filterValidGroups [] _ = ([], [])
filterValidGroups (ng:ngs) inst =
let (valid_ngs, msgs) = filterValidGroups ngs inst
in if hasRequiredNetworks (fst ng) inst
then (ng:valid_ngs, msgs)
else (valid_ngs,
("group " ++ Group.name (fst ng) ++
" is not connected to a network required by instance " ++
Instance.name inst):msgs)
findAllocation :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> Gdx
-> Instance.Instance
-> Int
-> Result (AllocSolution, [String])
findAllocation opts mggl mgnl mgil gdx inst cnt = do
let belongsTo nl' nidx = nidx `elem` map Node.idx (Container.elems nl')
nl = Container.filter ((== gdx) . Node.group) mgnl
il = Container.filter (belongsTo nl . Instance.pNode) mgil
group' = Container.find gdx mggl
unless (hasRequiredNetworks group' inst) . failError
$ "The group " ++ Group.name group' ++ " is not connected to\
\ a network required by instance " ++ Instance.name inst
solution <- genAllocNodes mggl nl cnt False >>= tryAlloc opts nl il inst
return (solution, solutionDescription (group', return solution))
findBestAllocGroup :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> Maybe [Gdx]
-> Instance.Instance
-> Int
-> Result (Group.Group, AllocSolution, [String])
findBestAllocGroup opts mggl mgnl mgil allowed_gdxs inst cnt =
let groups_by_idx = splitCluster mgnl mgil
groups = map (\(gid, d) -> (Container.find gid mggl, d)) groups_by_idx
groups' = maybe groups
(\gs -> filter ((`elem` gs) . Group.idx . fst) groups)
allowed_gdxs
(groups'', filter_group_msgs) = filterValidGroups groups' inst
sols = map (\(gr, (nl, il)) ->
(gr, genAllocNodes mggl nl cnt False >>=
tryAlloc opts nl il inst))
groups''::[(Group.Group, Result AllocSolution)]
all_msgs = filter_group_msgs ++ concatMap solutionDescription sols
goodSols = filterMGResults sols
sortedSols = sortMGResults goodSols
in case sortedSols of
[] -> Bad $ if null groups'
then "no groups for evacuation: allowed groups was " ++
show allowed_gdxs ++ ", all groups: " ++
show (map fst groups)
else intercalate ", " all_msgs
(final_group, final_sol):_ -> return (final_group, final_sol, all_msgs)
tryMGAlloc :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> Instance.Instance
-> Int
-> Result AllocSolution
tryMGAlloc opts mggl mgnl mgil inst cnt = do
(best_group, solution, all_msgs) <-
findBestAllocGroup opts mggl mgnl mgil Nothing inst cnt
let group_name = Group.name best_group
selmsg = "Selected group: " ++ group_name
return $ solution { asLog = selmsg:all_msgs }
tryGroupAlloc :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> String
-> Instance.Instance
-> Int
-> Result AllocSolution
tryGroupAlloc opts mggl mgnl ngil gn inst cnt = do
gdx <- Group.idx <$> Container.findByName mggl gn
(solution, msgs) <- findAllocation opts mggl mgnl ngil gdx inst cnt
return $ solution { asLog = msgs }
updateIl :: Instance.List
-> Maybe Node.AllocElement
-> Instance.List
updateIl il Nothing = il
updateIl il (Just (_, xi, _, _)) = Container.add (Container.size il) xi il
extractNl :: Node.List
-> Maybe Node.AllocElement
-> Node.List
extractNl nl Nothing = nl
extractNl _ (Just (xnl, _, _, _)) = xnl
allocList :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> [(Instance.Instance, AllocDetails)]
-> AllocSolutionList
-> Result (Node.List, Instance.List,
AllocSolutionList)
allocList _ _ nl il [] result = Ok (nl, il, result)
allocList opts gl nl il ((xi, AllocDetails xicnt mgn):xies) result = do
ares <- case mgn of
Nothing -> tryMGAlloc opts gl nl il xi xicnt
Just gn -> tryGroupAlloc opts gl nl il gn xi xicnt
let sol = asSolution ares
nl' = extractNl nl sol
il' = updateIl il sol
allocList opts gl nl' il' xies ((xi, ares):result)
failOnSecondaryChange :: (Monad m) => EvacMode -> DiskTemplate -> m ()
failOnSecondaryChange ChangeSecondary dt =
fail $ "Instances with disk template '" ++ diskTemplateToRaw dt ++
"' can't execute change secondary"
failOnSecondaryChange _ _ = return ()
nodeEvacInstance :: AlgorithmOptions
-> Node.List
-> Instance.List
-> EvacMode
-> Instance.Instance
-> Gdx
-> [Ndx]
-> Result (Node.List, Instance.List, [OpCodes.OpCode])
nodeEvacInstance opts nl il mode inst@(Instance.Instance
{Instance.diskTemplate = dt@DTDiskless})
gdx avail_nodes =
failOnSecondaryChange mode dt >>
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance _ _ _ _ (Instance.Instance
{Instance.diskTemplate = DTPlain}) _ _ =
fail "Instances of type plain cannot be relocated"
nodeEvacInstance _ _ _ _ (Instance.Instance
{Instance.diskTemplate = DTFile}) _ _ =
fail "Instances of type file cannot be relocated"
nodeEvacInstance opts nl il mode inst@(Instance.Instance
{Instance.diskTemplate = dt@DTSharedFile})
gdx avail_nodes =
failOnSecondaryChange mode dt >>
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance opts nl il mode inst@(Instance.Instance
{Instance.diskTemplate = dt@DTBlock})
gdx avail_nodes =
failOnSecondaryChange mode dt >>
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance opts nl il mode inst@(Instance.Instance
{Instance.diskTemplate = dt@DTRbd})
gdx avail_nodes =
failOnSecondaryChange mode dt >>
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance opts nl il mode inst@(Instance.Instance
{Instance.diskTemplate = dt@DTExt})
gdx avail_nodes =
failOnSecondaryChange mode dt >>
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance opts nl il mode inst@(Instance.Instance
{Instance.diskTemplate = dt@DTGluster})
gdx avail_nodes =
failOnSecondaryChange mode dt >>
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance opts nl il ChangePrimary
inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
_ _ =
do
(nl', inst', _, _) <- opToResult
$ applyMoveEx (algIgnoreSoftErrors opts) nl inst
Failover
let idx = Instance.idx inst
il' = Container.add idx inst' il
ops = iMoveToJob nl' il' idx Failover
return (nl', il', ops)
nodeEvacInstance opts nl il ChangeSecondary
inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
gdx avail_nodes =
evacOneNodeOnly opts nl il inst gdx avail_nodes
nodeEvacInstance opts nl il ChangeAll
inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
gdx avail_nodes =
do
let no_nodes = Left "no nodes available"
node_pairs = [(p,s) | p <- avail_nodes, s <- avail_nodes, p /= s]
(nl', il', ops, _) <-
annotateResult "Can't find any good nodes for relocation" .
eitherToResult $
foldl'
(\accu nodes -> case evacDrbdAllInner opts nl il inst gdx nodes of
Bad msg ->
case accu of
Right _ -> accu
Left _ -> Left $ "Allocation failed: " ++ msg
Ok result@(_, _, _, new_cv) ->
let new_accu = Right result in
case accu of
Left _ -> new_accu
Right (_, _, _, old_cv) ->
if old_cv < new_cv
then accu
else new_accu
) no_nodes node_pairs
return (nl', il', ops)
evacOneNodeOnly :: AlgorithmOptions
-> Node.List
-> Instance.List
-> Instance.Instance
-> Gdx
-> [Ndx]
-> Result (Node.List, Instance.List, [OpCodes.OpCode])
evacOneNodeOnly opts nl il inst gdx avail_nodes = do
op_fn <- case Instance.mirrorType inst of
MirrorNone -> Bad "Can't relocate/evacuate non-mirrored instances"
MirrorInternal -> Ok ReplaceSecondary
MirrorExternal -> Ok FailoverToAny
(nl', inst', _, ndx) <- annotateResult "Can't find any good node" .
eitherToResult $
foldl' (evacOneNodeInner opts nl inst gdx op_fn)
(Left "") avail_nodes
let idx = Instance.idx inst
il' = Container.add idx inst' il
ops = iMoveToJob nl' il' idx (op_fn ndx)
return (nl', il', ops)
evacOneNodeInner :: AlgorithmOptions
-> Node.List
-> Instance.Instance
-> Gdx
-> (Ndx -> IMove)
-> EvacInnerState
-> Ndx
-> EvacInnerState
evacOneNodeInner opts nl inst gdx op_fn accu ndx =
case applyMoveEx (algIgnoreSoftErrors opts) nl inst (op_fn ndx) of
Bad fm -> let fail_msg = " Node " ++ Container.nameOf nl ndx ++
" failed: " ++ show fm ++ ";"
in either (Left . (++ fail_msg)) Right accu
Ok (nl', inst', _, _) ->
let nodes = Container.elems nl'
grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
new_cv = compCVNodes grpnodes
new_accu = Right (nl', inst', new_cv, ndx)
in case accu of
Left _ -> new_accu
Right (_, _, old_cv, _) ->
if old_cv < new_cv
then accu
else new_accu
evacDrbdAllInner :: AlgorithmOptions
-> Node.List
-> Instance.List
-> Instance.Instance
-> Gdx
-> (Ndx, Ndx)
-> Result (Node.List, Instance.List, [OpCodes.OpCode], Score)
evacDrbdAllInner opts nl il inst gdx (t_pdx, t_sdx) = do
let primary = Container.find (Instance.pNode inst) nl
idx = Instance.idx inst
apMove = applyMoveEx $ algIgnoreSoftErrors opts
(nl1, inst1, ops1) <-
if Node.offline primary
then do
(nl', inst', _, _) <-
annotateResult "Failing over to the secondary" .
opToResult $ apMove nl inst Failover
return (nl', inst', [Failover])
else return (nl, inst, [])
let (o1, o2, o3) = (ReplaceSecondary t_pdx,
Failover,
ReplaceSecondary t_sdx)
(nl2, inst2, _, _) <-
annotateResult "Changing secondary to new primary" .
opToResult $
apMove nl1 inst1 o1
let ops2 = o1:ops1
(nl3, inst3, _, _) <- annotateResult "Failing over to new primary" .
opToResult $ apMove nl2 inst2 o2
let ops3 = o2:ops2
(nl4, inst4, _, _) <-
annotateResult "Changing secondary to final secondary" .
opToResult $
apMove nl3 inst3 o3
let ops4 = o3:ops3
il' = Container.add idx inst4 il
ops = concatMap (iMoveToJob nl4 il' idx) $ reverse ops4
let nodes = Container.elems nl4
grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
new_cv = compCVNodes grpnodes
return (nl4, il', ops, new_cv)
availableGroupNodes :: [(Gdx, [Ndx])]
-> IntSet.IntSet
-> Gdx
-> Result [Ndx]
availableGroupNodes group_nodes excl_ndx gdx = do
local_nodes <- maybe (Bad $ "Can't find group with index " ++ show gdx)
Ok (lookup gdx group_nodes)
let avail_nodes = filter (not . flip IntSet.member excl_ndx) local_nodes
return avail_nodes
updateEvacSolution :: (Node.List, Instance.List, EvacSolution)
-> Idx
-> Result (Node.List, Instance.List, [OpCodes.OpCode])
-> (Node.List, Instance.List, EvacSolution)
updateEvacSolution (nl, il, es) idx (Bad msg) =
(nl, il, es { esFailed = (idx, msg):esFailed es})
updateEvacSolution (_, _, es) idx (Ok (nl, il, opcodes)) =
(nl, il, es { esMoved = new_elem:esMoved es
, esOpCodes = opcodes:esOpCodes es })
where inst = Container.find idx il
new_elem = (idx,
instancePriGroup nl inst,
Instance.allNodes inst)
tryNodeEvac :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> EvacMode
-> [Idx]
-> Result (Node.List, Instance.List, EvacSolution)
tryNodeEvac opts _ ini_nl ini_il mode idxs =
let evac_ndx = nodesToEvacuate ini_il mode idxs
offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
excl_ndx = foldl' (flip IntSet.insert) evac_ndx offline
group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
(Container.elems nl))) $
splitCluster ini_nl ini_il
(fin_nl, fin_il, esol) =
foldl' (\state@(nl, il, _) inst ->
let gdx = instancePriGroup nl inst
pdx = Instance.pNode inst in
updateEvacSolution state (Instance.idx inst) $
availableGroupNodes group_ndx
(IntSet.insert pdx excl_ndx) gdx >>=
nodeEvacInstance opts nl il mode inst gdx
)
(ini_nl, ini_il, emptyEvacSolution)
(map (`Container.find` ini_il) idxs)
in return (fin_nl, fin_il, reverseEvacSolution esol)
tryChangeGroup :: AlgorithmOptions
-> Group.List
-> Node.List
-> Instance.List
-> [Gdx]
-> [Idx]
-> Result (Node.List, Instance.List, EvacSolution)
tryChangeGroup opts gl ini_nl ini_il gdxs idxs =
let evac_gdxs = nub $ map (instancePriGroup ini_nl .
flip Container.find ini_il) idxs
target_gdxs = (if null gdxs
then Container.keys gl
else gdxs) \\ evac_gdxs
offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
excl_ndx = foldl' (flip IntSet.insert) IntSet.empty offline
group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
(Container.elems nl))) $
splitCluster ini_nl ini_il
(fin_nl, fin_il, esol) =
foldl' (\state@(nl, il, _) inst ->
let solution = do
let ncnt = Instance.requiredNodes $
Instance.diskTemplate inst
(grp, _, _) <- findBestAllocGroup opts gl nl il
(Just target_gdxs) inst ncnt
let gdx = Group.idx grp
av_nodes <- availableGroupNodes group_ndx
excl_ndx gdx
nodeEvacInstance defaultOptions
nl il ChangeAll inst gdx av_nodes
in updateEvacSolution state (Instance.idx inst) solution
)
(ini_nl, ini_il, emptyEvacSolution)
(map (`Container.find` ini_il) idxs)
in return (fin_nl, fin_il, reverseEvacSolution esol)
iterateAlloc :: AlgorithmOptions -> AllocMethod
iterateAlloc opts nl il limit newinst allocnodes ixes cstats =
let depth = length ixes
newname = printf "new-%d" depth::String
newidx = Container.size il
newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
newlimit = fmap (flip () 1) limit
in case tryAlloc opts nl il newi2 allocnodes of
Bad s -> Bad s
Ok (AllocSolution { asFailures = errs, asSolution = sols3 }) ->
let newsol = Ok (collapseFailures errs, nl, il, ixes, cstats) in
case sols3 of
Nothing -> newsol
Just (xnl, xi, _, _) ->
if limit == Just 0
then newsol
else iterateAlloc opts xnl (Container.add newidx xi il)
newlimit newinst allocnodes (xi:ixes)
(totalResources xnl:cstats)
sufficesShrinking :: (Instance.Instance -> AllocSolution) -> Instance.Instance
-> FailMode -> Maybe Instance.Instance
sufficesShrinking allocFn inst fm =
case dropWhile (isNothing . asSolution . fst)
. takeWhile (liftA2 (||) (elem fm . asFailures . fst)
(isJust . asSolution . fst))
. map (allocFn &&& id) $
iterateOk (`Instance.shrinkByType` fm) inst
of x:_ -> Just . snd $ x
_ -> Nothing
tieredAlloc :: AlgorithmOptions -> AllocMethod
tieredAlloc opts nl il limit newinst allocnodes ixes cstats =
case iterateAlloc opts nl il limit newinst allocnodes ixes cstats of
Bad s -> Bad s
Ok (errs, nl', il', ixes', cstats') ->
let newsol = Ok (errs, nl', il', ixes', cstats')
ixes_cnt = length ixes'
(stop, newlimit) = case limit of
Nothing -> (False, Nothing)
Just n -> (n <= ixes_cnt,
Just (n ixes_cnt))
sortedErrs = map fst $ sortBy (comparing snd) errs
suffShrink = sufficesShrinking
(fromMaybe emptyAllocSolution
. flip (tryAlloc opts nl' il') allocnodes)
newinst
bigSteps = filter isJust . map suffShrink . reverse $ sortedErrs
progress (Ok (_, _, _, newil', _)) (Ok (_, _, _, newil, _)) =
length newil' > length newil
progress _ _ = False
in if stop then newsol else
let newsol' = case Instance.shrinkByType newinst . last
$ sortedErrs of
Bad _ -> newsol
Ok newinst' -> tieredAlloc opts nl' il' newlimit
newinst' allocnodes ixes' cstats'
in if progress newsol' newsol then newsol' else
case bigSteps of
Just newinst':_ -> tieredAlloc opts nl' il' newlimit
newinst' allocnodes ixes' cstats'
_ -> newsol
computeMoves :: Instance.Instance
-> String
-> IMove
-> String
-> String
-> (String, [String])
computeMoves i inam mv c d =
case mv of
Failover -> ("f", [mig])
FailoverToAny _ -> (printf "fa:%s" c, [mig_any])
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.isRunning i then "migrate" else "failover"
mig = printf "%s -f %s" morf inam::String
mig_any = printf "%s -f -n %s %s" morf c inam::String
rep n = printf "replace-disks -n %s %s" n inam::String
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
old_sec = Instance.sNode inst
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 old_sec nl
(moves, cmds) = computeMoves inst inam mv npri nsec
ostr = if old_sec == Node.noSecondary
then printf "%s" opri::String
else printf "%s:%s" opri osec::String
nstr = if s == Node.noSecondary
then printf "%s" npri::String
else printf "%s:%s" npri nsec::String
in (printf " %3d. %-*s %-*s => %-*s %12.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
in nub . filter (>= 0) $ [np, ns] ++ Instance.allNodes inst
getMoves :: (Table, Table) -> [MoveJob]
getMoves (Table _ initial_il _ initial_plc, Table final_nl _ _ final_plc) =
let
plctoMoves (plc@(idx, p, s, mv, _)) =
let inst = Container.find idx initial_il
inst_name = Instance.name inst
affected = involvedNodes initial_il plc
np = Node.alias $ Container.find p final_nl
ns = Node.alias $ Container.find s final_nl
(_, cmds) = computeMoves inst inst_name mv np ns
in (affected, idx, mv, cmds)
in map plctoMoves . reverse . drop (length initial_plc) $ reverse final_plc
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 printTable "" 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.isRunning 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
, if Instance.autoBalance inst then "Y" else "N"
, 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", "Auto_bal"
, "vcpu", "mem" , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
isnum = False:False:False:False:False:repeat True
in printTable "" header (map helper sil) isnum
printStats :: String -> Node.List -> String
printStats lp nl =
let dcvs = compDetailedCV $ Container.elems nl
(weights, names) = unzip detailedCVInfo
hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
header = [ "Field", "Value", "Weight" ]
formatted = map (\(w, h, val) ->
[ h
, printf "%.8f" val
, printf "x%.2f" w
]) hd
in printTable lp header formatted $ False:repeat True
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 n = case mkNonEmpty (Container.nameOf nl n) of
Bad msg -> error $ "Empty node name for idx " ++
show n ++ ": " ++ msg ++ "??"
Ok ne -> Just ne
opF = OpCodes.OpInstanceMigrate
{ OpCodes.opInstanceName = iname
, OpCodes.opInstanceUuid = Nothing
, OpCodes.opMigrationMode = Nothing
, OpCodes.opOldLiveMode = Nothing
, OpCodes.opTargetNode = Nothing
, OpCodes.opTargetNodeUuid = Nothing
, OpCodes.opAllowRuntimeChanges = False
, OpCodes.opIgnoreIpolicy = False
, OpCodes.opMigrationCleanup = False
, OpCodes.opIallocator = Nothing
, OpCodes.opAllowFailover = True
, OpCodes.opIgnoreHvversions = True
}
opFA n = opF { OpCodes.opTargetNode = lookNode n }
opR n = OpCodes.OpInstanceReplaceDisks
{ OpCodes.opInstanceName = iname
, OpCodes.opInstanceUuid = Nothing
, OpCodes.opEarlyRelease = False
, OpCodes.opIgnoreIpolicy = False
, OpCodes.opReplaceDisksMode = OpCodes.ReplaceNewSecondary
, OpCodes.opReplaceDisksList = []
, OpCodes.opRemoteNode = lookNode n
, OpCodes.opRemoteNodeUuid = Nothing
, OpCodes.opIallocator = Nothing
}
in case move of
Failover -> [ opF ]
FailoverToAny np -> [ opFA np ]
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 =
filter (not . isOk . instanceGroup nl) . Container.elems
splitCluster :: Node.List -> Instance.List ->
[(Gdx, (Node.List, Instance.List))]
splitCluster nl il =
let ngroups = Node.computeGroups (Container.elems nl)
in map (\(gdx, nodes) ->
let nidxs = map Node.idx nodes
nodes' = zip nidxs nodes
instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
in (gdx, (Container.fromList nodes', instances))) ngroups
nodesToEvacuate :: Instance.List
-> EvacMode
-> [Idx]
-> IntSet.IntSet
nodesToEvacuate il mode =
IntSet.delete Node.noSecondary .
foldl' (\ns idx ->
let i = Container.find idx il
pdx = Instance.pNode i
sdx = Instance.sNode i
dt = Instance.diskTemplate i
withSecondary = case dt of
DTDrbd8 -> IntSet.insert sdx ns
_ -> ns
in case mode of
ChangePrimary -> IntSet.insert pdx ns
ChangeSecondary -> withSecondary
ChangeAll -> IntSet.insert pdx withSecondary
) IntSet.empty