root / htools / Ganeti / HTools / Loader.hs @ 97da6b71
History | View | Annotate | Download (12.4 kB)
1 |
{-| Generic data loader. |
---|---|
2 |
|
3 |
This module holds the common code for parsing the input data after it |
4 |
has been loaded from external sources. |
5 |
|
6 |
-} |
7 |
|
8 |
{- |
9 |
|
10 |
Copyright (C) 2009, 2010, 2011 Google Inc. |
11 |
|
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. |
16 |
|
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. |
21 |
|
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 |
25 |
02110-1301, USA. |
26 |
|
27 |
-} |
28 |
|
29 |
module Ganeti.HTools.Loader |
30 |
( mergeData |
31 |
, checkData |
32 |
, assignIndices |
33 |
, lookupName |
34 |
, goodLookupResult |
35 |
, lookupNode |
36 |
, lookupInstance |
37 |
, lookupGroup |
38 |
, commonSuffix |
39 |
, RqType(..) |
40 |
, Request(..) |
41 |
, ClusterData(..) |
42 |
, emptyCluster |
43 |
, compareNameComponent |
44 |
, prefixMatch |
45 |
, LookupResult(..) |
46 |
, MatchPriority(..) |
47 |
) where |
48 |
|
49 |
import Data.List |
50 |
import Data.Function |
51 |
import qualified Data.Map as M |
52 |
import Text.Printf (printf) |
53 |
|
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 |
58 |
|
59 |
import Ganeti.HTools.Types |
60 |
import Ganeti.HTools.Utils |
61 |
|
62 |
-- * Constants |
63 |
|
64 |
-- | The exclusion tag prefix. |
65 |
exTagsPrefix :: String |
66 |
exTagsPrefix = "htools:iextags:" |
67 |
|
68 |
-- * Types |
69 |
|
70 |
{-| The iallocator request type. |
71 |
|
72 |
This type denotes what request we got from Ganeti and also holds |
73 |
request-specific fields. |
74 |
|
75 |
-} |
76 |
data RqType |
77 |
= Allocate Instance.Instance Int -- ^ A new instance allocation |
78 |
| NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode |
79 |
| ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode |
80 |
deriving (Show, Read) |
81 |
|
82 |
-- | A complete request, as received from Ganeti. |
83 |
data Request = Request RqType ClusterData |
84 |
deriving (Show, Read) |
85 |
|
86 |
-- | The cluster state. |
87 |
data ClusterData = ClusterData |
88 |
{ cdGroups :: Group.List -- ^ The node group list |
89 |
, cdNodes :: Node.List -- ^ The node list |
90 |
, cdInstances :: Instance.List -- ^ The instance list |
91 |
, cdTags :: [String] -- ^ The cluster tags |
92 |
} deriving (Show, Read) |
93 |
|
94 |
-- | The priority of a match in a lookup result. |
95 |
data MatchPriority = ExactMatch |
96 |
| MultipleMatch |
97 |
| PartialMatch |
98 |
| FailMatch |
99 |
deriving (Show, Read, Enum, Eq, Ord) |
100 |
|
101 |
-- | The result of a name lookup in a list. |
102 |
data LookupResult = LookupResult |
103 |
{ lrMatchPriority :: MatchPriority -- ^ The result type |
104 |
-- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise |
105 |
, lrContent :: String |
106 |
} deriving (Show, Read) |
107 |
|
108 |
-- | Lookup results have an absolute preference ordering. |
109 |
instance Eq LookupResult where |
110 |
(==) = (==) `on` lrMatchPriority |
111 |
|
112 |
instance Ord LookupResult where |
113 |
compare = compare `on` lrMatchPriority |
114 |
|
115 |
-- | An empty cluster. |
116 |
emptyCluster :: ClusterData |
117 |
emptyCluster = ClusterData Container.empty Container.empty Container.empty [] |
118 |
|
119 |
-- * Functions |
120 |
|
121 |
-- | Lookups a node into an assoc list. |
122 |
lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx |
123 |
lookupNode ktn inst node = |
124 |
case M.lookup node ktn of |
125 |
Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst |
126 |
Just idx -> return idx |
127 |
|
128 |
-- | Lookups an instance into an assoc list. |
129 |
lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx |
130 |
lookupInstance kti inst = |
131 |
case M.lookup inst kti of |
132 |
Nothing -> fail $ "Unknown instance '" ++ inst ++ "'" |
133 |
Just idx -> return idx |
134 |
|
135 |
-- | Lookups a group into an assoc list. |
136 |
lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx |
137 |
lookupGroup ktg nname gname = |
138 |
case M.lookup gname ktg of |
139 |
Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname |
140 |
Just idx -> return idx |
141 |
|
142 |
-- | Check for prefix matches in names. |
143 |
-- Implemented in Ganeti core utils.text.MatchNameComponent |
144 |
-- as the regexp r"^%s(\..*)?$" % re.escape(key) |
145 |
prefixMatch :: String -- ^ Lookup |
146 |
-> String -- ^ Full name |
147 |
-> Bool -- ^ Whether there is a prefix match |
148 |
prefixMatch lkp = isPrefixOf (lkp ++ ".") |
149 |
|
150 |
-- | Is the lookup priority a "good" one? |
151 |
goodMatchPriority :: MatchPriority -> Bool |
152 |
goodMatchPriority ExactMatch = True |
153 |
goodMatchPriority PartialMatch = True |
154 |
goodMatchPriority _ = False |
155 |
|
156 |
-- | Is the lookup result an actual match? |
157 |
goodLookupResult :: LookupResult -> Bool |
158 |
goodLookupResult = goodMatchPriority . lrMatchPriority |
159 |
|
160 |
-- | Compares a canonical name and a lookup string. |
161 |
compareNameComponent :: String -- ^ Canonical (target) name |
162 |
-> String -- ^ Partial (lookup) name |
163 |
-> LookupResult -- ^ Result of the lookup |
164 |
compareNameComponent cnl lkp = |
165 |
select (LookupResult FailMatch lkp) |
166 |
[ (cnl == lkp , LookupResult ExactMatch cnl) |
167 |
, (prefixMatch lkp cnl , LookupResult PartialMatch cnl) |
168 |
] |
169 |
|
170 |
-- | Lookup a string and choose the best result. |
171 |
chooseLookupResult :: String -- ^ Lookup key |
172 |
-> String -- ^ String to compare to the lookup key |
173 |
-> LookupResult -- ^ Previous result |
174 |
-> LookupResult -- ^ New result |
175 |
chooseLookupResult lkp cstr old = |
176 |
-- default: use class order to pick the minimum result |
177 |
select (min new old) |
178 |
-- special cases: |
179 |
-- short circuit if the new result is an exact match |
180 |
[ ((lrMatchPriority new) == ExactMatch, new) |
181 |
-- if both are partial matches generate a multiple match |
182 |
, (partial2, LookupResult MultipleMatch lkp) |
183 |
] where new = compareNameComponent cstr lkp |
184 |
partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] |
185 |
|
186 |
-- | Find the canonical name for a lookup string in a list of names. |
187 |
lookupName :: [String] -- ^ List of keys |
188 |
-> String -- ^ Lookup string |
189 |
-> LookupResult -- ^ Result of the lookup |
190 |
lookupName l s = foldr (chooseLookupResult s) |
191 |
(LookupResult FailMatch s) l |
192 |
|
193 |
-- | Given a list of elements (and their names), assign indices to them. |
194 |
assignIndices :: (Element a) => |
195 |
[(String, a)] |
196 |
-> (NameAssoc, Container.Container a) |
197 |
assignIndices nodes = |
198 |
let (na, idx_node) = |
199 |
unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx))) |
200 |
. zip [0..] $ nodes |
201 |
in (M.fromList na, Container.fromList idx_node) |
202 |
|
203 |
-- | For each instance, add its index to its primary and secondary nodes. |
204 |
fixNodes :: Node.List |
205 |
-> Instance.Instance |
206 |
-> Node.List |
207 |
fixNodes accu inst = |
208 |
let |
209 |
pdx = Instance.pNode inst |
210 |
sdx = Instance.sNode inst |
211 |
pold = Container.find pdx accu |
212 |
pnew = Node.setPri pold inst |
213 |
ac2 = Container.add pdx pnew accu |
214 |
in |
215 |
if sdx /= Node.noSecondary |
216 |
then let sold = Container.find sdx accu |
217 |
snew = Node.setSec sold inst |
218 |
in Container.add sdx snew ac2 |
219 |
else ac2 |
220 |
|
221 |
-- | Remove non-selected tags from the exclusion list. |
222 |
filterExTags :: [String] -> Instance.Instance -> Instance.Instance |
223 |
filterExTags tl inst = |
224 |
let old_tags = Instance.tags inst |
225 |
new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) |
226 |
old_tags |
227 |
in inst { Instance.tags = new_tags } |
228 |
|
229 |
-- | Update the movable attribute. |
230 |
updateMovable :: [String] -- ^ Selected instances (if not empty) |
231 |
-> [String] -- ^ Excluded instances |
232 |
-> Instance.Instance -- ^ Target Instance |
233 |
-> Instance.Instance -- ^ Target Instance with updated attribute |
234 |
updateMovable selinsts exinsts inst = |
235 |
if Instance.sNode inst == Node.noSecondary || |
236 |
Instance.name inst `elem` exinsts || |
237 |
not (null selinsts || Instance.name inst `elem` selinsts) |
238 |
then Instance.setMovable inst False |
239 |
else inst |
240 |
|
241 |
-- | Compute the longest common suffix of a list of strings that |
242 |
-- starts with a dot. |
243 |
longestDomain :: [String] -> String |
244 |
longestDomain [] = "" |
245 |
longestDomain (x:xs) = |
246 |
foldr (\ suffix accu -> if all (isSuffixOf suffix) xs |
247 |
then suffix |
248 |
else accu) |
249 |
"" $ filter (isPrefixOf ".") (tails x) |
250 |
|
251 |
-- | Extracts the exclusion tags from the cluster configuration. |
252 |
extractExTags :: [String] -> [String] |
253 |
extractExTags = |
254 |
map (drop (length exTagsPrefix)) . |
255 |
filter (isPrefixOf exTagsPrefix) |
256 |
|
257 |
-- | Extracts the common suffix from node\/instance names. |
258 |
commonSuffix :: Node.List -> Instance.List -> String |
259 |
commonSuffix nl il = |
260 |
let node_names = map Node.name $ Container.elems nl |
261 |
inst_names = map Instance.name $ Container.elems il |
262 |
in longestDomain (node_names ++ inst_names) |
263 |
|
264 |
-- | Initializer function that loads the data from a node and instance |
265 |
-- list and massages it into the correct format. |
266 |
mergeData :: [(String, DynUtil)] -- ^ Instance utilisation data |
267 |
-> [String] -- ^ Exclusion tags |
268 |
-> [String] -- ^ Selected instances (if not empty) |
269 |
-> [String] -- ^ Excluded instances |
270 |
-> ClusterData -- ^ Data from backends |
271 |
-> Result ClusterData -- ^ Fixed cluster data |
272 |
mergeData um extags selinsts exinsts cdata@(ClusterData _ nl il2 tags) = |
273 |
let il = Container.elems il2 |
274 |
il3 = foldl' (\im (name, n_util) -> |
275 |
case Container.findByName im name of |
276 |
Nothing -> im -- skipping unknown instance |
277 |
Just inst -> |
278 |
let new_i = inst { Instance.util = n_util } |
279 |
in Container.add (Instance.idx inst) new_i im |
280 |
) il2 um |
281 |
allextags = extags ++ extractExTags tags |
282 |
inst_names = map Instance.name il |
283 |
selinst_lkp = map (lookupName inst_names) selinsts |
284 |
exinst_lkp = map (lookupName inst_names) exinsts |
285 |
lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp) |
286 |
selinst_names = map lrContent selinst_lkp |
287 |
exinst_names = map lrContent exinst_lkp |
288 |
il4 = Container.map (filterExTags allextags . |
289 |
updateMovable selinst_names exinst_names) il3 |
290 |
nl2 = foldl' fixNodes nl (Container.elems il4) |
291 |
nl3 = Container.map (`Node.buildPeers` il4) nl2 |
292 |
node_names = map Node.name (Container.elems nl) |
293 |
common_suffix = longestDomain (node_names ++ inst_names) |
294 |
snl = Container.map (computeAlias common_suffix) nl3 |
295 |
sil = Container.map (computeAlias common_suffix) il4 |
296 |
in if' (null lkp_unknown) |
297 |
(Ok cdata { cdNodes = snl, cdInstances = sil }) |
298 |
(Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown)) |
299 |
|
300 |
-- | Checks the cluster data for consistency. |
301 |
checkData :: Node.List -> Instance.List |
302 |
-> ([String], Node.List) |
303 |
checkData nl il = |
304 |
Container.mapAccum |
305 |
(\ msgs node -> |
306 |
let nname = Node.name node |
307 |
nilst = map (`Container.find` il) (Node.pList node) |
308 |
dilst = filter (not . Instance.running) nilst |
309 |
adj_mem = sum . map Instance.mem $ dilst |
310 |
delta_mem = truncate (Node.tMem node) |
311 |
- Node.nMem node |
312 |
- Node.fMem node |
313 |
- nodeImem node il |
314 |
+ adj_mem |
315 |
delta_dsk = truncate (Node.tDsk node) |
316 |
- Node.fDsk node |
317 |
- nodeIdsk node il |
318 |
newn = Node.setFmem (Node.setXmem node delta_mem) |
319 |
(Node.fMem node - adj_mem) |
320 |
umsg1 = [printf "node %s is missing %d MB ram \ |
321 |
\and %d GB disk" |
322 |
nname delta_mem (delta_dsk `div` 1024) | |
323 |
delta_mem > 512 || delta_dsk > 1024]::[String] |
324 |
in (msgs ++ umsg1, newn) |
325 |
) [] nl |
326 |
|
327 |
-- | Compute the amount of memory used by primary instances on a node. |
328 |
nodeImem :: Node.Node -> Instance.List -> Int |
329 |
nodeImem node il = |
330 |
let rfind = flip Container.find il |
331 |
in sum . map (Instance.mem . rfind) |
332 |
$ Node.pList node |
333 |
|
334 |
-- | Compute the amount of disk used by instances on a node (either primary |
335 |
-- or secondary). |
336 |
nodeIdsk :: Node.Node -> Instance.List -> Int |
337 |
nodeIdsk node il = |
338 |
let rfind = flip Container.find il |
339 |
in sum . map (Instance.dsk . rfind) |
340 |
$ Node.pList node ++ Node.sList node |