X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/2c3273e7a0fbb7ead8b2e83d12a67a7c81d8ee09..7959cbb9e9bc627be364d3e3e404c3d45141ed16:/htools/Ganeti/HTools/Loader.hs diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs index b53d79c..169dd48 100644 --- a/htools/Ganeti/HTools/Loader.hs +++ b/htools/Ganeti/HTools/Loader.hs @@ -1,4 +1,4 @@ -{-| Generic data loader +{-| Generic data loader. This module holds the common code for parsing the input data after it has been loaded from external sources. @@ -7,7 +7,7 @@ has been loaded from external sources. {- -Copyright (C) 2009, 2010, 2011 Google Inc. +Copyright (C) 2009, 2010, 2011, 2012 Google Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -27,21 +27,27 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -} module Ganeti.HTools.Loader - ( mergeData - , checkData - , assignIndices - , lookupNode - , lookupInstance - , lookupGroup - , commonSuffix - , RelocMode(..) - , RqType(..) - , Request(..) - , ClusterData(..) - , emptyCluster - ) where + ( mergeData + , checkData + , assignIndices + , lookupName + , goodLookupResult + , lookupNode + , lookupInstance + , lookupGroup + , commonSuffix + , RqType(..) + , Request(..) + , ClusterData(..) + , emptyCluster + , compareNameComponent + , prefixMatch + , LookupResult(..) + , MatchPriority(..) + ) where import Data.List +import Data.Function import qualified Data.Map as M import Text.Printf (printf) @@ -51,21 +57,16 @@ import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.Group as Group import Ganeti.HTools.Types +import Ganeti.HTools.Utils -- * Constants --- | The exclusion tag prefix +-- | The exclusion tag prefix. exTagsPrefix :: String exTagsPrefix = "htools:iextags:" -- * Types --- | The iallocator multi-evac group mode type. -data RelocMode = KeepGroup - | ChangeGroup [Gdx] - | AnyGroup - deriving (Show, Read) - {-| The iallocator request type. This type denotes what request we got from Ganeti and also holds @@ -73,51 +74,124 @@ request-specific fields. -} data RqType - = Allocate Instance.Instance Int -- ^ A new instance allocation - | Relocate Idx Int [Ndx] -- ^ Move an instance to a new - -- secondary node - | Evacuate [Ndx] -- ^ Evacuate nodes - | MultiReloc [Idx] RelocMode -- ^ Multi-relocate mode + = Allocate Instance.Instance Int -- ^ A new instance allocation + | Relocate Idx Int [Ndx] -- ^ Choose a new secondary node + | NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode + | ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode deriving (Show, Read) -- | A complete request, as received from Ganeti. data Request = Request RqType ClusterData - deriving (Show, Read) + deriving (Show, Read) -- | 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 - } deriving (Show, Read) + { 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, Read, Eq) + +-- | The priority of a match in a lookup result. +data MatchPriority = ExactMatch + | MultipleMatch + | PartialMatch + | FailMatch + deriving (Show, Read, Enum, Eq, Ord) + +-- | The result of a name lookup in a list. +data LookupResult = LookupResult + { lrMatchPriority :: MatchPriority -- ^ The result type + -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise + , lrContent :: String + } deriving (Show, Read) + +-- | Lookup results have an absolute preference ordering. +instance Eq LookupResult where + (==) = (==) `on` lrMatchPriority + +instance Ord LookupResult where + compare = compare `on` lrMatchPriority -- | 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 = - case M.lookup node ktn of - Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst - Just idx -> return idx + case M.lookup node ktn of + Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst + Just idx -> return idx -- | Lookups an instance into an assoc list. lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx lookupInstance kti inst = - case M.lookup inst kti of - Nothing -> fail $ "Unknown instance '" ++ inst ++ "'" - Just idx -> return idx + case M.lookup inst kti of + Nothing -> fail $ "Unknown instance '" ++ inst ++ "'" + Just idx -> return idx -- | Lookups a group into an assoc list. lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx lookupGroup ktg nname gname = - case M.lookup gname ktg of - Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname - Just idx -> return idx + case M.lookup gname ktg of + Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname + Just idx -> return idx + +-- | Check for prefix matches in names. +-- Implemented in Ganeti core utils.text.MatchNameComponent +-- as the regexp r"^%s(\..*)?$" % re.escape(key) +prefixMatch :: String -- ^ Lookup + -> String -- ^ Full name + -> Bool -- ^ Whether there is a prefix match +prefixMatch = isPrefixOf . (++ ".") + +-- | Is the lookup priority a "good" one? +goodMatchPriority :: MatchPriority -> Bool +goodMatchPriority ExactMatch = True +goodMatchPriority PartialMatch = True +goodMatchPriority _ = False + +-- | Is the lookup result an actual match? +goodLookupResult :: LookupResult -> Bool +goodLookupResult = goodMatchPriority . lrMatchPriority + +-- | Compares a canonical name and a lookup string. +compareNameComponent :: String -- ^ Canonical (target) name + -> String -- ^ Partial (lookup) name + -> LookupResult -- ^ Result of the lookup +compareNameComponent cnl lkp = + select (LookupResult FailMatch lkp) + [ (cnl == lkp , LookupResult ExactMatch cnl) + , (prefixMatch lkp cnl , LookupResult PartialMatch cnl) + ] + +-- | Lookup a string and choose the best result. +chooseLookupResult :: String -- ^ Lookup key + -> String -- ^ String to compare to the lookup key + -> LookupResult -- ^ Previous result + -> LookupResult -- ^ New result +chooseLookupResult lkp cstr old = + -- default: use class order to pick the minimum result + select (min new old) + -- special cases: + -- short circuit if the new result is an exact match + [ (lrMatchPriority new == ExactMatch, new) + -- if both are partial matches generate a multiple match + , (partial2, LookupResult MultipleMatch lkp) + ] where new = compareNameComponent cstr lkp + partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] + +-- | Find the canonical name for a lookup string in a list of names. +lookupName :: [String] -- ^ List of keys + -> String -- ^ Lookup string + -> LookupResult -- ^ Result of the lookup +lookupName l s = foldr (chooseLookupResult s) + (LookupResult FailMatch s) l -- | Given a list of elements (and their names), assign indices to them. assignIndices :: (Element a) => @@ -134,66 +208,77 @@ 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 - --- | Remove non-selected tags from the exclusion list + 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 + +-- | Remove non-selected tags from the exclusion list. filterExTags :: [String] -> Instance.Instance -> Instance.Instance filterExTags tl inst = - let old_tags = Instance.tags inst - new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) - old_tags - in inst { Instance.tags = new_tags } - --- | Update the movable attribute -updateMovable :: [String] -> Instance.Instance -> Instance.Instance -updateMovable exinst inst = - if Instance.sNode inst == Node.noSecondary || - Instance.name inst `elem` exinst + let old_tags = Instance.tags inst + new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) old_tags + in inst { Instance.tags = new_tags } + +-- | 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.sNode inst == Node.noSecondary || + Instance.name inst `elem` exinsts || + not (null selinsts || Instance.name inst `elem` selinsts) then Instance.setMovable inst False else inst -- | Compute the longest common suffix of a list of strings that --- | starts with a dot. +-- 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) + foldr (\ suffix accu -> if all (isSuffixOf suffix) xs + then suffix + else accu) + "" $ filter (isPrefixOf ".") (tails x) --- | Extracts the exclusion tags from the cluster configuration +-- | Extracts the exclusion tags from the cluster configuration. extractExTags :: [String] -> [String] extractExTags = - map (drop (length exTagsPrefix)) . - filter (isPrefixOf exTagsPrefix) + map (drop (length exTagsPrefix)) . + filter (isPrefixOf exTagsPrefix) --- | Extracts the common suffix from node\/instance names +-- | 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) + let node_names = map Node.name $ Container.elems nl + inst_names = map Instance.name $ Container.elems il + in longestDomain (node_names ++ inst_names) -- | 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] -- ^ Untouchable instances + -> [String] -- ^ Selected instances (if not empty) + -> [String] -- ^ Excluded instances -> ClusterData -- ^ Data from backends -> Result ClusterData -- ^ Fixed cluster data -mergeData um extags exinsts cdata@(ClusterData _ nl il2 tags) = +mergeData um extags selinsts exinsts cdata@(ClusterData gl nl il2 tags _) = let il = Container.elems il2 il3 = foldl' (\im (name, n_util) -> case Container.findByName im name of @@ -203,20 +288,24 @@ mergeData um extags exinsts cdata@(ClusterData _ nl il2 tags) = in Container.add (Instance.idx inst) new_i im ) il2 um allextags = extags ++ extractExTags tags - il4 = Container.map (filterExTags allextags . - updateMovable exinsts) il3 - nl2 = foldl' fixNodes nl (Container.elems il4) - nl3 = Container.map (flip Node.buildPeers il4) nl2 - node_names = map Node.name (Container.elems nl) inst_names = map Instance.name il + 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) - snl = Container.map (computeAlias common_suffix) nl3 - sil = Container.map (computeAlias common_suffix) il4 - all_inst_names = concatMap allNames $ Container.elems sil - in if not $ all (`elem` all_inst_names) exinsts - then Bad $ "Some of the excluded instances are unknown: " ++ - show (exinsts \\ all_inst_names) - else Ok cdata { cdNodes = snl, cdInstances = sil } + il4 = Container.map (computeAlias common_suffix . + filterExTags allextags . + updateMovable selinst_names exinst_names) il3 + nl2 = foldl' fixNodes nl (Container.elems il4) + nl3 = Container.map (setNodePolicy gl . + computeAlias common_suffix . + (`Node.buildPeers` il4)) nl2 + in if' (null lkp_unknown) + (Ok cdata { cdNodes = nl3, cdInstances = il4 }) + (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown)) -- | Checks the cluster data for consistency. checkData :: Node.List -> Instance.List @@ -226,7 +315,7 @@ checkData nl il = (\ msgs node -> let nname = Node.name node nilst = map (`Container.find` il) (Node.pList node) - dilst = filter (not . Instance.running) nilst + dilst = filter Instance.instanceDown nilst adj_mem = sum . map Instance.mem $ dilst delta_mem = truncate (Node.tMem node) - Node.nMem node @@ -238,24 +327,28 @@ checkData nl il = - nodeIdsk node il newn = Node.setFmem (Node.setXmem node delta_mem) (Node.fMem node - adj_mem) - umsg1 = [printf "node %s is missing %d MB ram \ - \and %d GB disk" - nname delta_mem (delta_dsk `div` 1024) | - delta_mem > 512 || delta_dsk > 1024]::[String] - in (msgs ++ umsg1, newn) + 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 - in sum . map (Instance.mem . rfind) - $ Node.pList node + let rfind = flip Container.find il + il' = map rfind $ Node.pList node + oil' = filter Instance.notOffline 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 + let rfind = flip Container.find il + in sum . map (Instance.dsk . rfind) + $ Node.pList node ++ Node.sList node