{-
-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
( mergeData
, checkData
, assignIndices
- , lookupName
- , goodLookupResult
, lookupNode
, lookupInstance
, lookupGroup
, 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.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 Ganeti.BasicTypes
import Ganeti.HTools.Types
-import Ganeti.HTools.Utils
+import Ganeti.Utils
-- * Constants
-}
data RqType
- = 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)
+ = 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
+ | MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode
+ deriving (Show)
-- | A complete request, as received from Ganeti.
data Request = Request RqType ClusterData
- deriving (Show, Read)
+ deriving (Show)
-- | The cluster state.
data ClusterData = ClusterData
, cdNodes :: Node.List -- ^ The node list
, cdInstances :: Instance.List -- ^ The instance list
, cdTags :: [String] -- ^ The cluster tags
- } deriving (Show, Read)
-
--- | 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
+ , 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 =
- case M.lookup node ktn of
- Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
- Just idx -> return idx
+ 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 =
- case M.lookup inst kti of
- Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
- Just idx -> return idx
+ 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 =
- 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
+ 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) =>
in Container.add sdx snew ac2
else ac2
--- | 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 }
+-- | 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 the movable attribute.
updateMovable :: [String] -- ^ Selected instances (if not empty)
-> 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 ||
+ 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
+
-- | Compute the longest common suffix of a list of strings that
-- starts with a dot.
longestDomain :: [String] -> String
-> [String] -- ^ Excluded instances
-> ClusterData -- ^ Data from backends
-> Result ClusterData -- ^ Fixed cluster data
-mergeData um extags selinsts 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
lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
selinst_names = map lrContent selinst_lkp
exinst_names = map lrContent exinst_lkp
- il4 = Container.map (filterExTags allextags .
- updateMovable selinst_names exinst_names) il3
- nl2 = foldl' fixNodes nl (Container.elems il4)
- nl3 = Container.map (`Node.buildPeers` il4) nl2
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
+ il4 = Container.map (computeAlias common_suffix .
+ updateExclTags 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
+ il5 = Container.map (disableSplitMoves nl3) il4
in if' (null lkp_unknown)
- (Ok cdata { cdNodes = snl, cdInstances = sil })
+ (Ok cdata { cdNodes = nl3, cdInstances = il5 })
(Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))
-- | Checks the cluster data for consistency.
- 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 il =
let rfind = flip Container.find il
il' = map rfind $ Node.pList node
- oil' = filter (not . Instance.instanceOffline) il'
+ oil' = filter Instance.notOffline il'
in sum . map Instance.mem $ oil'