| {-| Implementation of special handling of dedicated clusters. |
| |
| -} |
| |
| {- |
| |
| Copyright (C) 2014 Google Inc. |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are |
| met: |
| |
| 1. Redistributions of source code must retain the above copyright notice, |
| this list of conditions and the following disclaimer. |
| |
| 2. Redistributions in binary form must reproduce the above copyright |
| notice, this list of conditions and the following disclaimer in the |
| documentation and/or other materials provided with the distribution. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS |
| IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED |
| TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR |
| PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR |
| CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, |
| EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, |
| PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
| PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
| LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
| NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| |
| -} |
| |
| module Ganeti.HTools.Dedicated |
| ( isDedicated |
| , testInstances |
| , allocationVector |
| , Metric |
| , lostAllocationsMetric |
| , allocateOnSingle |
| , allocateOnPair |
| , findAllocation |
| , runDedicatedAllocation |
| ) where |
| |
| import Prelude () |
| import Ganeti.Prelude |
| |
| import Control.Applicative (liftA2) |
| import Control.Arrow ((&&&)) |
| import Control.Monad (unless, liftM, foldM, mplus) |
| import qualified Data.Foldable as F |
| import Data.Function (on) |
| import qualified Data.IntMap as IntMap |
| import qualified Data.IntSet as IntSet |
| import Data.List (sortBy, intercalate) |
| |
| import Ganeti.BasicTypes (iterateOk, Result, failError) |
| import qualified Ganeti.HTools.AlgorithmParams as Alg |
| import qualified Ganeti.HTools.Backend.IAlloc as IAlloc |
| import qualified Ganeti.HTools.Cluster as Cluster |
| import qualified Ganeti.HTools.Cluster.AllocationSolution as AllocSol |
| import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils |
| import qualified Ganeti.HTools.Container as Container |
| import qualified Ganeti.HTools.Group as Group |
| import qualified Ganeti.HTools.Instance as Instance |
| import qualified Ganeti.HTools.Loader as Loader |
| import qualified Ganeti.HTools.Node as Node |
| import qualified Ganeti.HTools.Types as T |
| |
| -- | Given a cluster description and maybe a group name, decide |
| -- if that group, or all allocatable groups if no group is given, |
| -- is dedicated. |
| isDedicated :: Loader.ClusterData -> Maybe String -> Bool |
| isDedicated cdata maybeGroup = |
| let groups = |
| IntMap.keysSet |
| . IntMap.filter (maybe ((/=) T.AllocUnallocable . Group.allocPolicy) |
| (\name -> (==) name . Group.name) maybeGroup) |
| $ Loader.cdGroups cdata |
| in F.all (liftA2 (||) Node.exclStorage |
| $ not . (`IntSet.member` groups) . Node.group) |
| $ Loader.cdNodes cdata |
| |
| -- | Given a specification interval, create an instance minimally fitting |
| -- into that interval. In other words create an instance from the lower bounds |
| -- of the specified interval. |
| minimallyCompliantInstance :: T.ISpec -> Instance.Instance |
| minimallyCompliantInstance spec = |
| Instance.create "minimalspecinstance" |
| (T.iSpecMemorySize spec) |
| (T.iSpecDiskSize spec) |
| [] |
| (T.iSpecCpuCount spec) |
| T.Running [] False Node.noSecondary Node.noSecondary T.DTPlain |
| (T.iSpecSpindleUse spec) |
| [] False |
| |
| -- | From an instance policy get the list of test instances, in correct order, |
| -- for which the allocation count has to be determined for the lost allocations |
| -- metrics. |
| testInstances :: T.IPolicy -> [Instance.Instance] |
| testInstances = |
| map minimallyCompliantInstance |
| . sortBy (flip compare `on` T.iSpecDiskSize) |
| . map T.minMaxISpecsMinSpec |
| . T.iPolicyMinMaxISpecs |
| |
| -- | Given the test instances, compute the allocations vector of a node |
| allocationVector :: [Instance.Instance] -> Node.Node -> [Int] |
| allocationVector insts node = |
| map (\ inst -> length $ iterateOk (`Node.addPri` inst) node) insts |
| |
| -- | The metric do be used in dedicated allocation. |
| type Metric = ([Int], Int) |
| |
| -- | Given the test instances and an instance to be placed, compute |
| -- the lost allocations metrics for that node, together with the |
| -- modified node. Return Bad if it is not possible to place the |
| -- instance on that node. |
| lostAllocationsMetric :: Alg.AlgorithmOptions |
| -> [Instance.Instance] |
| -> Instance.Instance |
| -> Node.Node |
| -> T.OpResult (Metric, Node.Node) |
| lostAllocationsMetric opts insts inst node = do |
| let allocVec = allocationVector insts |
| before = allocVec node |
| force = Alg.algIgnoreSoftErrors opts |
| node' <- Node.addPriEx force node inst |
| let after = allocVec node' |
| disk = Node.fDsk node' |
| return ((zipWith (-) before after, disk), node') |
| |
| -- | Allocate an instance on a given node. |
| allocateOnSingle :: Alg.AlgorithmOptions |
| -> Node.List -> Instance.Instance -> T.Ndx |
| -> T.OpResult (AllocSol.GenericAllocElement Metric) |
| allocateOnSingle opts nl inst new_pdx = do |
| let primary = Container.find new_pdx nl |
| policy = Node.iPolicy primary |
| testInst = testInstances policy |
| excl = Node.exclStorage primary |
| new_inst = Instance.setBoth inst new_pdx Node.noSecondary |
| Instance.instMatchesPolicy inst policy excl |
| (metrics, new_p) <- lostAllocationsMetric opts testInst inst primary |
| let new_nl = Container.add new_pdx new_p nl |
| return (new_nl, new_inst, [new_p], metrics) |
| |
| -- | Allocate an instance on a given pair of nodes. |
| allocateOnPair :: Alg.AlgorithmOptions |
| -> Node.List |
| -> Instance.Instance |
| -> T.Ndx |
| -> T.Ndx |
| -> T.OpResult (AllocSol.GenericAllocElement Metric) |
| allocateOnPair opts nl inst pdx sdx = do |
| let primary = Container.find pdx nl |
| secondary = Container.find sdx nl |
| policy = Node.iPolicy primary |
| testInst = testInstances policy |
| inst' = Instance.setBoth inst pdx sdx |
| Instance.instMatchesPolicy inst policy (Node.exclStorage primary) |
| ((lAllP, dskP), primary') <- lostAllocationsMetric opts testInst inst' primary |
| secondary' <- Node.addSec secondary inst' pdx |
| let lAllS = zipWith (-) (allocationVector testInst secondary) |
| (allocationVector testInst secondary') |
| dskS = Node.fDsk secondary' |
| metric = (zipWith (+) lAllP lAllS, dskP + dskS) |
| nl' = Container.addTwo pdx primary' sdx secondary' nl |
| return (nl', inst', [primary', secondary'], metric) |
| |
| -- | Find an allocation for an instance on a group. |
| findAllocation :: Alg.AlgorithmOptions |
| -> Group.List |
| -> Node.List |
| -> T.Gdx |
| -> Instance.Instance |
| -> Int |
| -> Result (AllocSol.GenericAllocSolution Metric, [String]) |
| findAllocation opts mggl mgnl gdx inst count = do |
| let nl = Container.filter ((== gdx) . Node.group) mgnl |
| group = Container.find gdx mggl |
| unless (Cluster.hasRequiredNetworks group inst) . failError |
| $ "The group " ++ Group.name group ++ " is not connected to\ |
| \ a network required by instance " ++ Instance.name inst |
| allocNodes <- Cluster.genAllocNodes opts mggl nl count False |
| solution <- case allocNodes of |
| (Right []) -> fail "Not enough online nodes" |
| (Right pairs) -> |
| let sols = foldl AllocSol.sumAllocs AllocSol.emptyAllocSolution |
| $ map (\(p, ss) -> foldl |
| (\cstate -> |
| AllocSol.concatAllocs cstate |
| . allocateOnPair opts nl inst p) |
| AllocSol.emptyAllocSolution ss) |
| pairs |
| in return $ AllocSol.genericAnnotateSolution show sols |
| (Left []) -> fail "No online nodes" |
| (Left nodes) -> |
| let sols = foldl (\cstate -> |
| AllocSol.concatAllocs cstate |
| . allocateOnSingle opts nl inst) |
| AllocSol.emptyAllocSolution nodes |
| in return $ AllocSol.genericAnnotateSolution show sols |
| return (solution, AllocSol.solutionDescription (group, return solution)) |
| |
| -- | Find an allocation in a suitable group. |
| findMGAllocation :: Alg.AlgorithmOptions |
| -> Group.List |
| -> Node.List |
| -> Instance.List |
| -> Instance.Instance |
| -> Int |
| -> Result (AllocSol.GenericAllocSolution Metric) |
| findMGAllocation opts gl nl il inst count = do |
| let groups_by_idx = ClusterUtils.splitCluster nl il |
| genSol (gdx, (nl', _)) = |
| liftM fst $ findAllocation opts gl nl' gdx inst count |
| sols = map (flip Container.find gl . fst &&& genSol) groups_by_idx |
| goodSols = Cluster.sortMGResults $ Cluster.filterMGResults sols |
| all_msgs = concatMap AllocSol.solutionDescription sols |
| case goodSols of |
| [] -> fail $ intercalate ", " all_msgs |
| (final_group, final_sol):_ -> |
| let sel_msg = "Selected group: " ++ Group.name final_group |
| in return $ final_sol { AllocSol.asLog = sel_msg : all_msgs } |
| |
| -- | Handle allocation requests in the dedicated scenario. |
| runDedicatedAllocation :: Alg.AlgorithmOptions |
| -> Loader.Request |
| -> (Maybe (Node.List, Instance.List), String) |
| runDedicatedAllocation opts request = |
| let Loader.Request rqtype (Loader.ClusterData gl nl il _ _) = request |
| allocresult = |
| case rqtype of |
| Loader.Allocate inst (Cluster.AllocDetails count (Just gn)) rNds -> do |
| gdx <- Group.idx <$> Container.findByName gl gn |
| let opts' = opts { Alg.algRestrictToNodes = |
| Alg.algRestrictToNodes opts `mplus` rNds } |
| (solution, msgs) <- findAllocation opts' gl nl gdx inst count |
| IAlloc.formatAllocate il $ solution { AllocSol.asLog = msgs } |
| Loader.Allocate inst (Cluster.AllocDetails count Nothing) rNds -> |
| let opts' = opts { Alg.algRestrictToNodes = |
| Alg.algRestrictToNodes opts `mplus` rNds } |
| in findMGAllocation opts' gl nl il inst count |
| >>= IAlloc.formatAllocate il |
| Loader.MultiAllocate insts -> |
| IAlloc.formatMultiAlloc =<< foldM |
| (\(nl', il', res) |
| (inst, Cluster.AllocDetails count maybeGroup) -> do |
| ares <- maybe (findMGAllocation opts gl nl' il' inst count) |
| (\gn -> do |
| gdx <- Group.idx <$> Container.findByName gl gn |
| liftM fst |
| $ findAllocation opts gl nl gdx inst count) |
| maybeGroup |
| let sol = AllocSol.asSolution ares |
| nl'' = AllocSol.extractNl nl' il' sol |
| il'' = AllocSol.updateIl il' sol |
| return (nl'', il'', (inst, ares):res)) |
| (nl, il, []) insts |
| _ -> fail "Dedicated Allocation only for proper allocation requests" |
| in IAlloc.formatIAllocResult allocresult |
