| {-| Generic data loader. |
| |
| This module holds the common code for parsing the input data after it |
| has been loaded from external sources. |
| |
| -} |
| |
| {- |
| |
| Copyright (C) 2009, 2010, 2011, 2012 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.Loader |
| ( mergeData |
| , clearDynU |
| , checkData |
| , assignIndices |
| , setMaster |
| , lookupNode |
| , lookupInstance |
| , lookupGroup |
| , eitherLive |
| , commonSuffix |
| , extractExTags |
| , updateExclTags |
| , RqType(..) |
| , Request(..) |
| , ClusterData(..) |
| , isAllocationRequest |
| , emptyCluster |
| , obtainNodeMemory |
| , extractDesiredLocations |
| , updateDesiredLocationTags |
| ) where |
| |
| import Control.Monad |
| import Data.List |
| import qualified Data.Map as M |
| import Data.Maybe |
| import qualified Data.Set as Set |
| import Text.Printf (printf) |
| import System.Time (ClockTime(..)) |
| |
| 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 qualified Ganeti.HTools.Cluster as Cluster |
| import qualified Ganeti.HTools.Cluster.Moves as Moves |
| |
| import Ganeti.BasicTypes |
| import qualified Ganeti.HTools.Tags as Tags |
| import qualified Ganeti.HTools.Tags.Constants as TagsC |
| import Ganeti.HTools.Types |
| import qualified Ganeti.Types as T |
| import qualified Ganeti.Objects as O |
| import Ganeti.Utils |
| import Ganeti.Types (EvacMode) |
| import Ganeti.JSON |
| |
| -- * Types |
| |
| {-| The iallocator request type. |
| |
| This type denotes what request we got from Ganeti and also holds |
| request-specific fields. |
| |
| -} |
| data RqType |
| = Allocate Instance.Instance Cluster.AllocDetails (Maybe [String]) |
| -- ^ A new instance allocation, maybe with allocation restrictions |
| | AllocateSecondary Idx -- ^ Find a suitable |
| -- secondary node for disk |
| -- conversion |
| | Relocate Idx Int [Ndx] -- ^ Choose a new |
| -- secondary node |
| | NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode |
| | ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode |
| | MultiAllocate [(Instance.Instance, Cluster.AllocDetails)] |
| -- ^ Multi-allocate mode |
| deriving (Show) |
| |
| -- | A complete request, as received from Ganeti. |
| data Request = Request RqType ClusterData |
| deriving (Show) |
| |
| -- | Decide whether a request asks to allocate new instances; if so, also |
| -- return the desired node group, if a unique node group is specified. |
| -- That is, return `Nothing` if the request is not an allocation request, |
| -- `Just Nothing`, if it is an Allocation request, but there is no unique |
| -- group specified, and return `Just (Just g)` if it is an allocation request |
| -- uniquely requesting Group `g`. |
| isAllocationRequest :: RqType -> Maybe (Maybe String) |
| isAllocationRequest (Allocate _ (Cluster.AllocDetails _ grp) _) = Just grp |
| isAllocationRequest (MultiAllocate reqs) = Just $ |
| case ordNub . catMaybes |
| $ map (\(_, Cluster.AllocDetails _ grp) -> grp) reqs of |
| [grp] -> Just grp |
| _ -> Nothing |
| isAllocationRequest _ = Nothing |
| |
| -- | The cluster state. |
| data ClusterData = ClusterData |
| { cdGroups :: Group.List -- ^ The node group list |
| , cdNodes :: Node.List -- ^ The node list |
| , cdInstances :: Instance.List -- ^ The instance list |
| , cdTags :: [String] -- ^ The cluster tags |
| , cdIPolicy :: IPolicy -- ^ The cluster instance policy |
| } deriving (Show, Eq) |
| |
| -- | An empty cluster. |
| emptyCluster :: ClusterData |
| emptyCluster = ClusterData Container.empty Container.empty Container.empty [] |
| defIPolicy |
| |
| -- * Functions |
| |
| -- | Lookups a node into an assoc list. |
| lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx |
| lookupNode ktn inst node = |
| maybe (fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst) return $ |
| M.lookup node ktn |
| |
| -- | Lookups an instance into an assoc list. |
| lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx |
| lookupInstance kti inst = |
| maybe (fail $ "Unknown instance '" ++ inst ++ "'") return $ M.lookup inst kti |
| |
| -- | Lookups a group into an assoc list. |
| lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx |
| lookupGroup ktg nname gname = |
| maybe (fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname) return $ |
| M.lookup gname ktg |
| |
| -- | Given a list of elements (and their names), assign indices to them. |
| assignIndices :: (Element a) => |
| [(String, a)] |
| -> (NameAssoc, Container.Container a) |
| assignIndices name_element = |
| let (name_idx, idx_element) = |
| unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx))) |
| . zip [0..] $ name_element |
| in (M.fromList name_idx, Container.fromList idx_element) |
| |
| -- | Given am indexed node list, and the name of the master, mark it as such. |
| setMaster :: (Monad m) => NameAssoc -> Node.List -> String -> m Node.List |
| setMaster node_names node_idx master = do |
| kmaster <- maybe (fail $ "Master node " ++ master ++ " unknown") return $ |
| M.lookup master node_names |
| let mnode = Container.find kmaster node_idx |
| return $ Container.add kmaster (Node.setMaster mnode True) node_idx |
| |
| -- | Given the nodes with the location tags already set correctly, compute |
| -- the location score for an instance. |
| setLocationScore :: Node.List -> Instance.Instance -> Instance.Instance |
| setLocationScore nl inst = |
| let pnode = Container.find (Instance.pNode inst) nl |
| snode = Container.find (Instance.sNode inst) nl |
| in Moves.setInstanceLocationScore inst pnode snode |
| |
| -- | For each instance, add its index to its primary and secondary nodes. |
| fixNodes :: Node.List |
| -> Instance.Instance |
| -> Node.List |
| fixNodes accu inst = |
| let pdx = Instance.pNode inst |
| sdx = Instance.sNode inst |
| pold = Container.find pdx accu |
| pnew = Node.setPri pold inst |
| ac2 = Container.add pdx pnew accu |
| in if sdx /= Node.noSecondary |
| then let sold = Container.find sdx accu |
| snew = Node.setSec sold inst |
| in Container.add sdx snew ac2 |
| else ac2 |
| |
| -- | Set the node's policy to its group one. Note that this requires |
| -- the group to exist (should have been checked before), otherwise it |
| -- will abort with a runtime error. |
| setNodePolicy :: Group.List -> Node.Node -> Node.Node |
| setNodePolicy gl node = |
| let grp = Container.find (Node.group node) gl |
| gpol = Group.iPolicy grp |
| in Node.setPolicy gpol node |
| |
| -- | Update instance with exclusion tags list. |
| updateExclTags :: [String] -> Instance.Instance -> Instance.Instance |
| updateExclTags tl inst = |
| let allTags = Instance.allTags inst |
| exclTags = filter (\tag -> any (`isPrefixOf` tag) tl) allTags |
| in inst { Instance.exclTags = exclTags } |
| |
| -- | Update instance with desired location tags list. |
| updateDesiredLocationTags :: [String] -> Instance.Instance -> Instance.Instance |
| updateDesiredLocationTags tl inst = |
| let allTags = Instance.allTags inst |
| dsrdLocTags = filter (\tag -> any (`isPrefixOf` tag) tl) allTags |
| in inst { Instance.dsrdLocTags = Set.fromList dsrdLocTags } |
| |
| |
| -- | Update the movable attribute. |
| updateMovable :: [String] -- ^ Selected instances (if not empty) |
| -> [String] -- ^ Excluded instances |
| -> Instance.Instance -- ^ Target Instance |
| -> Instance.Instance -- ^ Target Instance with updated attribute |
| updateMovable selinsts exinsts inst = |
| if Instance.name inst `elem` exinsts || |
| not (null selinsts || Instance.name inst `elem` selinsts) |
| then Instance.setMovable inst False |
| else inst |
| |
| -- | Disables moves for instances with a split group. |
| disableSplitMoves :: Node.List -> Instance.Instance -> Instance.Instance |
| disableSplitMoves nl inst = |
| if not . isOk . Cluster.instanceGroup nl $ inst |
| then Instance.setMovable inst False |
| else inst |
| |
| -- | Set the auto-repair policy for an instance. |
| setArPolicy :: [String] -- ^ Cluster tags |
| -> Group.List -- ^ List of node groups |
| -> Node.List -- ^ List of nodes |
| -> Instance.List -- ^ List of instances |
| -> ClockTime -- ^ Current timestamp, to evaluate ArSuspended |
| -> Instance.List -- ^ Updated list of instances |
| setArPolicy ctags gl nl il time = |
| let getArPolicy' = flip getArPolicy time |
| cpol = fromMaybe ArNotEnabled $ getArPolicy' ctags |
| gpols = Container.map (fromMaybe cpol . getArPolicy' . Group.allTags) gl |
| ipolfn = getArPolicy' . Instance.allTags |
| nlookup = flip Container.find nl . Instance.pNode |
| glookup = flip Container.find gpols . Node.group . nlookup |
| updateInstance inst = inst { |
| Instance.arPolicy = fromMaybe (glookup inst) $ ipolfn inst } |
| in |
| Container.map updateInstance il |
| |
| -- | Get the auto-repair policy from a list of tags. |
| -- |
| -- This examines the ganeti:watcher:autorepair and |
| -- ganeti:watcher:autorepair:suspend tags to determine the policy. If none of |
| -- these tags are present, Nothing (and not ArNotEnabled) is returned. |
| getArPolicy :: [String] -> ClockTime -> Maybe AutoRepairPolicy |
| getArPolicy tags time = |
| let enabled = mapMaybe (autoRepairTypeFromRaw <=< |
| chompPrefix TagsC.autoRepairTagEnabled) tags |
| suspended = mapMaybe (chompPrefix TagsC.autoRepairTagSuspended) tags |
| futureTs = filter (> time) . map (flip TOD 0) $ |
| mapMaybe (tryRead "auto-repair suspend time") suspended |
| in |
| case () of |
| -- Note how we must return ArSuspended even if "enabled" is empty, so that |
| -- node groups or instances can suspend repairs that were enabled at an |
| -- upper scope (cluster or node group). |
| _ | "" `elem` suspended -> Just $ ArSuspended Forever |
| | not $ null futureTs -> Just . ArSuspended . Until . maximum $ futureTs |
| | not $ null enabled -> Just $ ArEnabled (minimum enabled) |
| | otherwise -> Nothing |
| |
| -- | Compute the longest common suffix of a list of strings that |
| -- starts with a dot. |
| longestDomain :: [String] -> String |
| longestDomain [] = "" |
| longestDomain (x:xs) = |
| foldr (\ suffix accu -> if all (isSuffixOf suffix) xs |
| then suffix |
| else accu) |
| "" $ filter (isPrefixOf ".") (tails x) |
| |
| -- | Extracts the exclusion tags from the cluster configuration. |
| extractExTags :: [String] -> [String] |
| extractExTags = filter (not . null) . mapMaybe (chompPrefix TagsC.exTagsPrefix) |
| |
| -- | Extracts the desired locations from the instance tags. |
| extractDesiredLocations :: [String] -> [String] |
| extractDesiredLocations = |
| filter (not . null) . mapMaybe (chompPrefix TagsC.desiredLocationPrefix) |
| |
| -- | Extracts the common suffix from node\/instance names. |
| commonSuffix :: Node.List -> Instance.List -> String |
| commonSuffix nl il = |
| let node_names = map Node.name $ Container.elems nl |
| inst_names = map Instance.name $ Container.elems il |
| in longestDomain (node_names ++ inst_names) |
| |
| -- | Set the migration-related tags on a node given the cluster tags; |
| -- this assumes that the node tags are already set on that node. |
| addMigrationTags :: [String] -- ^ cluster tags |
| -> Node.Node -> Node.Node |
| addMigrationTags ctags node = |
| let ntags = Node.nTags node |
| migTags = Tags.getMigRestrictions ctags ntags |
| rmigTags = Tags.getRecvMigRestrictions ctags ntags |
| in Node.setRecvMigrationTags (Node.setMigrationTags node migTags) rmigTags |
| |
| -- | Set the location tags on a node given the cluster tags; |
| -- this assumes that the node tags are already set on that node. |
| addLocationTags :: [String] -- ^ cluster tags |
| -> Node.Node -> Node.Node |
| addLocationTags ctags node = |
| let ntags = Node.nTags node |
| in Node.setLocationTags node $ Tags.getLocations ctags ntags |
| |
| -- | Initializer function that loads the data from a node and instance |
| -- list and massages it into the correct format. |
| mergeData :: [(String, DynUtil)] -- ^ Instance utilisation data |
| -> [String] -- ^ Exclusion tags |
| -> [String] -- ^ Selected instances (if not empty) |
| -> [String] -- ^ Excluded instances |
| -> ClockTime -- ^ The current timestamp |
| -> ClusterData -- ^ Data from backends |
| -> Result ClusterData -- ^ Fixed cluster data |
| mergeData um extags selinsts exinsts time cdata@(ClusterData gl nl il ctags _) = |
| let il2 = setArPolicy ctags gl nl il time |
| il3 = foldl' (\im (name, n_util) -> |
| case Container.findByName im name of |
| Nothing -> im -- skipping unknown instance |
| Just inst -> |
| let new_i = inst { Instance.util = n_util } |
| in Container.add (Instance.idx inst) new_i im |
| ) il2 um |
| allextags = extags ++ extractExTags ctags |
| dsrdLocTags = extractDesiredLocations ctags |
| inst_names = map Instance.name $ Container.elems il3 |
| selinst_lkp = map (lookupName inst_names) selinsts |
| exinst_lkp = map (lookupName inst_names) exinsts |
| lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp) |
| selinst_names = map lrContent selinst_lkp |
| exinst_names = map lrContent exinst_lkp |
| node_names = map Node.name (Container.elems nl) |
| common_suffix = longestDomain (node_names ++ inst_names) |
| il4 = Container.map (computeAlias common_suffix . |
| updateExclTags allextags . |
| updateDesiredLocationTags dsrdLocTags . |
| updateMovable selinst_names exinst_names) il3 |
| nl2 = Container.map (addLocationTags ctags) nl |
| il5 = Container.map (setLocationScore nl2) il4 |
| nl3 = foldl' fixNodes nl2 (Container.elems il5) |
| nl4 = Container.map (setNodePolicy gl . |
| computeAlias common_suffix . |
| (`Node.buildPeers` il4)) nl3 |
| il6 = Container.map (disableSplitMoves nl3) il5 |
| nl5 = Container.map (addMigrationTags ctags) nl4 |
| in if' (null lkp_unknown) |
| (Ok cdata { cdNodes = nl5, cdInstances = il6 }) |
| (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown)) |
| |
| -- | In a cluster description, clear dynamic utilisation information. |
| clearDynU :: ClusterData -> Result ClusterData |
| clearDynU cdata@(ClusterData _ _ il _ _) = |
| let il2 = Container.map (\ inst -> inst {Instance.util = zeroUtil }) il |
| in Ok cdata { cdInstances = il2 } |
| |
| -- | Checks the cluster data for consistency. |
| checkData :: Node.List -> Instance.List |
| -> ([String], Node.List) |
| checkData nl il = |
| Container.mapAccum |
| (\ msgs node -> |
| let nname = Node.name node |
| delta_mem = truncate (Node.tMem node) |
| - Node.nMem node |
| - Node.fMem node |
| - nodeImem node il |
| delta_dsk = truncate (Node.tDsk node) |
| - Node.fDsk node |
| - nodeIdsk node il |
| newn = node `Node.setXmem` delta_mem |
| umsg1 = |
| if delta_mem > 512 || delta_dsk > 1024 |
| then printf "node %s is missing %d MB ram \ |
| \and %d GB disk" |
| nname delta_mem (delta_dsk `div` 1024):msgs |
| else msgs |
| in (umsg1, newn) |
| ) [] nl |
| |
| -- | Compute the amount of memory used by primary instances on a node. |
| nodeImem :: Node.Node -> Instance.List -> Int |
| nodeImem node il = |
| let rfind = flip Container.find il |
| il' = map rfind $ Node.pList node |
| oil' = filter Instance.usesMemory il' |
| in sum . map Instance.mem $ oil' |
| |
| |
| -- | Compute the amount of disk used by instances on a node (either primary |
| -- or secondary). |
| nodeIdsk :: Node.Node -> Instance.List -> Int |
| nodeIdsk node il = |
| let rfind = flip Container.find il |
| in sum . map (Instance.dsk . rfind) |
| $ Node.pList node ++ Node.sList node |
| |
| -- | Get live information or a default value |
| eitherLive :: (Monad m) => Bool -> a -> m a -> m a |
| eitherLive True _ live_data = live_data |
| eitherLive False def_data _ = return def_data |
| |
| -- | Obtains memory used by node. It's memory_dom0 for Xen and memNode |
| -- otherwise because live data collector exists only for Xen |
| obtainNodeMemory :: O.FilledHvState -> Int -> Int |
| obtainNodeMemory hv_state memory_dom0 = |
| let getNM ((_, hvs):_) 0 = O.hvstateMemNode hvs |
| getNM ((T.XenPvm, _):_) mem_dom0 = mem_dom0 |
| getNM ((T.XenHvm, _):_) mem_dom0 = mem_dom0 |
| getNM ((_, hvs):_) _ = O.hvstateMemNode hvs |
| getNM _ mem_dom0 = mem_dom0 |
| in getNM (M.toList $ fromContainer hv_state) memory_dom0 |
