1 {-| Generic data loader.
3 This module holds the common code for parsing the input data after it
4 has been loaded from external sources.
10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
12 This program is free software; you can redistribute it and/or modify
13 it under the terms of the GNU General Public License as published by
14 the Free Software Foundation; either version 2 of the License, or
15 (at your option) any later version.
17 This program is distributed in the hope that it will be useful, but
18 WITHOUT ANY WARRANTY; without even the implied warranty of
19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 General Public License for more details.
22 You should have received a copy of the GNU General Public License
23 along with this program; if not, write to the Free Software
24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 module Ganeti.HTools.Loader
43 , compareNameComponent
51 import qualified Data.Map as M
52 import Text.Printf (printf)
54 import qualified Ganeti.HTools.Container as Container
55 import qualified Ganeti.HTools.Instance as Instance
56 import qualified Ganeti.HTools.Node as Node
57 import qualified Ganeti.HTools.Group as Group
59 import Ganeti.HTools.Types
60 import Ganeti.HTools.Utils
64 -- | The exclusion tag prefix.
65 exTagsPrefix :: String
66 exTagsPrefix = "htools:iextags:"
70 {-| The iallocator request type.
72 This type denotes what request we got from Ganeti and also holds
73 request-specific fields.
77 = Allocate Instance.Instance Int -- ^ A new instance allocation
78 | Relocate Idx Int [Ndx] -- ^ Choose a new secondary node
79 | NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode
80 | ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode
83 -- | A complete request, as received from Ganeti.
84 data Request = Request RqType ClusterData
87 -- | The cluster state.
88 data ClusterData = ClusterData
89 { cdGroups :: Group.List -- ^ The node group list
90 , cdNodes :: Node.List -- ^ The node list
91 , cdInstances :: Instance.List -- ^ The instance list
92 , cdTags :: [String] -- ^ The cluster tags
93 , cdIPolicy :: IPolicy -- ^ The cluster instance policy
94 } deriving (Show, Read, Eq)
96 -- | The priority of a match in a lookup result.
97 data MatchPriority = ExactMatch
101 deriving (Show, Read, Enum, Eq, Ord)
103 -- | The result of a name lookup in a list.
104 data LookupResult = LookupResult
105 { lrMatchPriority :: MatchPriority -- ^ The result type
106 -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
107 , lrContent :: String
108 } deriving (Show, Read)
110 -- | Lookup results have an absolute preference ordering.
111 instance Eq LookupResult where
112 (==) = (==) `on` lrMatchPriority
114 instance Ord LookupResult where
115 compare = compare `on` lrMatchPriority
117 -- | An empty cluster.
118 emptyCluster :: ClusterData
119 emptyCluster = ClusterData Container.empty Container.empty Container.empty []
124 -- | Lookups a node into an assoc list.
125 lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
126 lookupNode ktn inst node =
127 case M.lookup node ktn of
128 Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
129 Just idx -> return idx
131 -- | Lookups an instance into an assoc list.
132 lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
133 lookupInstance kti inst =
134 case M.lookup inst kti of
135 Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
136 Just idx -> return idx
138 -- | Lookups a group into an assoc list.
139 lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
140 lookupGroup ktg nname gname =
141 case M.lookup gname ktg of
142 Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
143 Just idx -> return idx
145 -- | Check for prefix matches in names.
146 -- Implemented in Ganeti core utils.text.MatchNameComponent
147 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
148 prefixMatch :: String -- ^ Lookup
149 -> String -- ^ Full name
150 -> Bool -- ^ Whether there is a prefix match
151 prefixMatch = isPrefixOf . (++ ".")
153 -- | Is the lookup priority a "good" one?
154 goodMatchPriority :: MatchPriority -> Bool
155 goodMatchPriority ExactMatch = True
156 goodMatchPriority PartialMatch = True
157 goodMatchPriority _ = False
159 -- | Is the lookup result an actual match?
160 goodLookupResult :: LookupResult -> Bool
161 goodLookupResult = goodMatchPriority . lrMatchPriority
163 -- | Compares a canonical name and a lookup string.
164 compareNameComponent :: String -- ^ Canonical (target) name
165 -> String -- ^ Partial (lookup) name
166 -> LookupResult -- ^ Result of the lookup
167 compareNameComponent cnl lkp =
168 select (LookupResult FailMatch lkp)
169 [ (cnl == lkp , LookupResult ExactMatch cnl)
170 , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
173 -- | Lookup a string and choose the best result.
174 chooseLookupResult :: String -- ^ Lookup key
175 -> String -- ^ String to compare to the lookup key
176 -> LookupResult -- ^ Previous result
177 -> LookupResult -- ^ New result
178 chooseLookupResult lkp cstr old =
179 -- default: use class order to pick the minimum result
182 -- short circuit if the new result is an exact match
183 [ (lrMatchPriority new == ExactMatch, new)
184 -- if both are partial matches generate a multiple match
185 , (partial2, LookupResult MultipleMatch lkp)
186 ] where new = compareNameComponent cstr lkp
187 partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
189 -- | Find the canonical name for a lookup string in a list of names.
190 lookupName :: [String] -- ^ List of keys
191 -> String -- ^ Lookup string
192 -> LookupResult -- ^ Result of the lookup
193 lookupName l s = foldr (chooseLookupResult s)
194 (LookupResult FailMatch s) l
196 -- | Given a list of elements (and their names), assign indices to them.
197 assignIndices :: (Element a) =>
199 -> (NameAssoc, Container.Container a)
200 assignIndices nodes =
202 unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
204 in (M.fromList na, Container.fromList idx_node)
206 -- | For each instance, add its index to its primary and secondary nodes.
207 fixNodes :: Node.List
211 let pdx = Instance.pNode inst
212 sdx = Instance.sNode inst
213 pold = Container.find pdx accu
214 pnew = Node.setPri pold inst
215 ac2 = Container.add pdx pnew accu
216 in if sdx /= Node.noSecondary
217 then let sold = Container.find sdx accu
218 snew = Node.setSec sold inst
219 in Container.add sdx snew ac2
222 -- | Set the node's policy to its group one. Note that this requires
223 -- the group to exist (should have been checked before), otherwise it
224 -- will abort with a runtime error.
225 setNodePolicy :: Group.List -> Node.Node -> Node.Node
226 setNodePolicy gl node =
227 let grp = Container.find (Node.group node) gl
228 gpol = Group.iPolicy grp
229 in Node.setPolicy gpol node
231 -- | Remove non-selected tags from the exclusion list.
232 filterExTags :: [String] -> Instance.Instance -> Instance.Instance
233 filterExTags tl inst =
234 let old_tags = Instance.tags inst
235 new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) old_tags
236 in inst { Instance.tags = new_tags }
238 -- | Update the movable attribute.
239 updateMovable :: [String] -- ^ Selected instances (if not empty)
240 -> [String] -- ^ Excluded instances
241 -> Instance.Instance -- ^ Target Instance
242 -> Instance.Instance -- ^ Target Instance with updated attribute
243 updateMovable selinsts exinsts inst =
244 if Instance.name inst `elem` exinsts ||
245 not (null selinsts || Instance.name inst `elem` selinsts)
246 then Instance.setMovable inst False
249 -- | Compute the longest common suffix of a list of strings that
250 -- starts with a dot.
251 longestDomain :: [String] -> String
252 longestDomain [] = ""
253 longestDomain (x:xs) =
254 foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
257 "" $ filter (isPrefixOf ".") (tails x)
259 -- | Extracts the exclusion tags from the cluster configuration.
260 extractExTags :: [String] -> [String]
262 map (drop (length exTagsPrefix)) .
263 filter (isPrefixOf exTagsPrefix)
265 -- | Extracts the common suffix from node\/instance names.
266 commonSuffix :: Node.List -> Instance.List -> String
268 let node_names = map Node.name $ Container.elems nl
269 inst_names = map Instance.name $ Container.elems il
270 in longestDomain (node_names ++ inst_names)
272 -- | Initializer function that loads the data from a node and instance
273 -- list and massages it into the correct format.
274 mergeData :: [(String, DynUtil)] -- ^ Instance utilisation data
275 -> [String] -- ^ Exclusion tags
276 -> [String] -- ^ Selected instances (if not empty)
277 -> [String] -- ^ Excluded instances
278 -> ClusterData -- ^ Data from backends
279 -> Result ClusterData -- ^ Fixed cluster data
280 mergeData um extags selinsts exinsts cdata@(ClusterData gl nl il2 tags _) =
281 let il = Container.elems il2
282 il3 = foldl' (\im (name, n_util) ->
283 case Container.findByName im name of
284 Nothing -> im -- skipping unknown instance
286 let new_i = inst { Instance.util = n_util }
287 in Container.add (Instance.idx inst) new_i im
289 allextags = extags ++ extractExTags tags
290 inst_names = map Instance.name il
291 selinst_lkp = map (lookupName inst_names) selinsts
292 exinst_lkp = map (lookupName inst_names) exinsts
293 lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
294 selinst_names = map lrContent selinst_lkp
295 exinst_names = map lrContent exinst_lkp
296 node_names = map Node.name (Container.elems nl)
297 common_suffix = longestDomain (node_names ++ inst_names)
298 il4 = Container.map (computeAlias common_suffix .
299 filterExTags allextags .
300 updateMovable selinst_names exinst_names) il3
301 nl2 = foldl' fixNodes nl (Container.elems il4)
302 nl3 = Container.map (setNodePolicy gl .
303 computeAlias common_suffix .
304 (`Node.buildPeers` il4)) nl2
305 in if' (null lkp_unknown)
306 (Ok cdata { cdNodes = nl3, cdInstances = il4 })
307 (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))
309 -- | Checks the cluster data for consistency.
310 checkData :: Node.List -> Instance.List
311 -> ([String], Node.List)
315 let nname = Node.name node
316 nilst = map (`Container.find` il) (Node.pList node)
317 dilst = filter Instance.instanceDown nilst
318 adj_mem = sum . map Instance.mem $ dilst
319 delta_mem = truncate (Node.tMem node)
324 delta_dsk = truncate (Node.tDsk node)
327 newn = Node.setFmem (Node.setXmem node delta_mem)
328 (Node.fMem node - adj_mem)
330 if delta_mem > 512 || delta_dsk > 1024
331 then printf "node %s is missing %d MB ram \
333 nname delta_mem (delta_dsk `div` 1024):msgs
338 -- | Compute the amount of memory used by primary instances on a node.
339 nodeImem :: Node.Node -> Instance.List -> Int
341 let rfind = flip Container.find il
342 il' = map rfind $ Node.pList node
343 oil' = filter Instance.notOffline il'
344 in sum . map Instance.mem $ oil'
347 -- | Compute the amount of disk used by instances on a node (either primary
349 nodeIdsk :: Node.Node -> Instance.List -> Int
351 let rfind = flip Container.find il
352 in sum . map (Instance.dsk . rfind)
353 $ Node.pList node ++ Node.sList node