, doNextBalance
, tryBalance
, compCV
+ , compCVNodes
, compDetailedCV
, printStats
, iMoveToJob
import Data.Function (on)
import qualified Data.IntSet as IntSet
import Data.List
+import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Text.Printf (printf)
import Control.Monad
detailedCVWeights = map fst detailedCVInfo
-- | Compute the mem and disk covariance.
-compDetailedCV :: Node.List -> [Double]
-compDetailedCV nl =
+compDetailedCV :: [Node.Node] -> [Double]
+compDetailedCV all_nodes =
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
, pri_tags_score ]
-- | Compute the /total/ variance.
+compCVNodes :: [Node.Node] -> Double
+compCVNodes = sum . zipWith (*) detailedCVWeights . compDetailedCV
+
+-- | Wrapper over 'compCVNodes' for callers that have a 'Node.List'.
compCV :: Node.List -> Double
-compCV = sum . zipWith (*) detailedCVWeights . compDetailedCV
+compCV = compCVNodes . Container.elems
+
-- | Compute online nodes from a 'Node.List'.
getOnline :: Node.List -> [Node.Node]
-- | Build failure stats out of a list of failures.
collapseFailures :: [FailMode] -> FailStats
collapseFailures flst =
- map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
+ map (\k -> (k, foldl' (\a e -> if e == k then a + 1 else a) 0 flst))
+ [minBound..maxBound]
-- | Update current Allocation solution and failure stats with new
-- elements.
ops = iMoveToJob nl' il' idx Failover
return (nl', il', ops)
-nodeEvacInstance _ _ _ (Instance.Instance
- {Instance.diskTemplate = DTDrbd8}) _ =
- fail "DRBD relocations not implemented yet"
+nodeEvacInstance nl il ChangeSecondary
+ inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
+ avail_nodes =
+ do
+ let gdx = instancePriGroup nl inst
+ (nl', inst', _, ndx) <- annotateResult "Can't find any good node" $
+ eitherToResult $
+ foldl' (evacDrbdSecondaryInner nl inst gdx)
+ (Left "no nodes available") avail_nodes
+ let idx = Instance.idx inst
+ il' = Container.add idx inst' il
+ ops = iMoveToJob nl' il' idx (ReplaceSecondary ndx)
+ return (nl', il', ops)
+
+nodeEvacInstance nl il ChangeAll
+ inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
+ avail_nodes =
+ do
+ let primary = Container.find (Instance.pNode inst) nl
+ idx = Instance.idx inst
+ gdx = instancePriGroup nl inst
+ no_nodes = Left "no nodes available"
+ -- if the primary is offline, then we first failover
+ (nl1, inst1, ops1) <-
+ if Node.offline primary
+ then do
+ (nl', inst', _, _) <-
+ annotateResult "Failing over to the secondary" $
+ opToResult $ applyMove nl inst Failover
+ return (nl', inst', [Failover])
+ else return (nl, inst, [])
+ -- we now need to execute a replace secondary to the future
+ -- primary node
+ (nl2, inst2, _, new_pdx) <- annotateResult "Searching for a new primary" $
+ eitherToResult $
+ foldl' (evacDrbdSecondaryInner nl1 inst1 gdx)
+ no_nodes avail_nodes
+ let ops2 = ReplaceSecondary new_pdx:ops1
+ -- since we chose the new primary, we remove it from the list of
+ -- available nodes
+ let avail_nodes_sec = new_pdx `delete` avail_nodes
+ -- we now execute another failover, the primary stays fixed now
+ (nl3, inst3, _, _) <- annotateResult "Failing over to new primary" $
+ opToResult $ applyMove nl2 inst2 Failover
+ let ops3 = Failover:ops2
+ -- and finally another replace secondary, to the final secondary
+ (nl4, inst4, _, new_sdx) <-
+ annotateResult "Searching for a new secondary" $
+ eitherToResult $
+ foldl' (evacDrbdSecondaryInner nl3 inst3 gdx) no_nodes avail_nodes_sec
+ let ops4 = ReplaceSecondary new_sdx:ops3
+ il' = Container.add idx inst4 il
+ ops = concatMap (iMoveToJob nl4 il' idx) $ reverse ops4
+ return (nl4, il', ops)
+
+-- | Inner fold function for changing secondary of a DRBD instance.
+--
+-- The "running" solution is either a @Left String@, which means we
+-- don't have yet a working solution, or a @Right (...)@, which
+-- represents a valid solution; it holds the modified node list, the
+-- modified instance (after evacuation), the score of that solution,
+-- and the new secondary node index.
+evacDrbdSecondaryInner :: Node.List -- ^ Cluster node list
+ -> Instance.Instance -- ^ Instance being evacuated
+ -> Gdx -- ^ The group index of the instance
+ -> Either String ( Node.List
+ , Instance.Instance
+ , Score
+ , Ndx) -- ^ Current best solution
+ -> Ndx -- ^ Node we're evaluating as new secondary
+ -> Either String ( Node.List
+ , Instance.Instance
+ , Score
+ , Ndx) -- ^ New best solution
+evacDrbdSecondaryInner nl inst gdx accu ndx =
+ case applyMove nl inst (ReplaceSecondary ndx) of
+ OpFail fm ->
+ case accu of
+ Right _ -> accu
+ Left _ -> Left $ "Node " ++ Container.nameOf nl ndx ++
+ " failed: " ++ show fm
+ OpGood (nl', inst', _, _) ->
+ let nodes = Container.elems nl'
+ -- The fromJust below is ugly (it can fail nastily), but
+ -- at this point we should have any internal mismatches,
+ -- and adding a monad here would be quite involved
+ 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
-- | Computes the local nodes of a given instance which are available
-- for allocation.
-- | Recursively place instances on the cluster until we're out of space.
iterateAlloc :: Node.List
-> Instance.List
+ -> Maybe Int
-> Instance.Instance
-> AllocNodes
-> [Instance.Instance]
-> [CStats]
-> Result AllocResult
-iterateAlloc nl il newinst allocnodes ixes cstats =
+iterateAlloc nl il limit 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
+ newlimit = fmap (flip (-) 1) limit
in case tryAlloc nl il newi2 allocnodes of
Bad s -> Bad s
Ok (AllocSolution { asFailures = errs, asSolutions = sols3 }) ->
+ let newsol = Ok (collapseFailures errs, nl, il, ixes, cstats) in
case sols3 of
- [] -> Ok (collapseFailures errs, nl, il, ixes, cstats)
+ [] -> newsol
(xnl, xi, _, _):[] ->
- iterateAlloc xnl (Container.add newidx xi il)
- newinst allocnodes (xi:ixes)
- (totalResources xnl:cstats)
+ if limit == Just 0
+ then newsol
+ else iterateAlloc xnl (Container.add newidx xi il)
+ newlimit newinst allocnodes (xi:ixes)
+ (totalResources xnl:cstats)
_ -> Bad "Internal error: multiple solutions for single\
\ allocation"
-- | The core of the tiered allocation mode.
tieredAlloc :: Node.List
-> Instance.List
+ -> Maybe Int
-> Instance.Instance
-> AllocNodes
-> [Instance.Instance]
-> [CStats]
-> Result AllocResult
-tieredAlloc nl il newinst allocnodes ixes cstats =
- case iterateAlloc nl il newinst allocnodes ixes cstats of
+tieredAlloc nl il limit newinst allocnodes ixes cstats =
+ case iterateAlloc 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)) in
+ if stop then newsol else
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'
+ Bad _ -> newsol
+ Ok newinst' -> tieredAlloc nl' il' newlimit
+ newinst' allocnodes ixes' cstats'
-- | Compute the tiered spec string description from a list of
-- allocated instances.
-- | Shows statistics for a given node list.
printStats :: Node.List -> String
printStats nl =
- let dcvs = compDetailedCV nl
+ let dcvs = compDetailedCV $ Container.elems nl
(weights, names) = unzip detailedCVInfo
hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
formatted = map (\(w, header, val) ->
projects / ganeti-local / blobdiff