-{-| 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.
{-
-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
-}
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)
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
-}
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) =>
-> 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
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
(\ 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
- 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
projects / ganeti-local / blobdiff