Loader.hs 12.9 KB
Newer Older
1
{-| Generic data loader.
Iustin Pop's avatar
Iustin Pop committed
2

3
4
This module holds the common code for parsing the input data after it
has been loaded from external sources.
Iustin Pop's avatar
Iustin Pop committed
5
6
7

-}

Iustin Pop's avatar
Iustin Pop committed
8
9
{-

Iustin Pop's avatar
Iustin Pop committed
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
Iustin Pop's avatar
Iustin Pop committed
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

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
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

Iustin Pop's avatar
Iustin Pop committed
29
module Ganeti.HTools.Loader
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
  ( mergeData
  , checkData
  , assignIndices
  , lookupName
  , goodLookupResult
  , lookupNode
  , lookupInstance
  , lookupGroup
  , commonSuffix
  , RqType(..)
  , Request(..)
  , ClusterData(..)
  , emptyCluster
  , compareNameComponent
  , prefixMatch
  , LookupResult(..)
  , MatchPriority(..)
  ) where
Iustin Pop's avatar
Iustin Pop committed
48

Iustin Pop's avatar
Iustin Pop committed
49
import Data.List
50
import Data.Function
51
import qualified Data.Map as M
52
import Text.Printf (printf)
Iustin Pop's avatar
Iustin Pop committed
53
54
55
56

import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
57
import qualified Ganeti.HTools.Group as Group
Iustin Pop's avatar
Iustin Pop committed
58
59

import Ganeti.HTools.Types
60
import Ganeti.HTools.Utils
Iustin Pop's avatar
Iustin Pop committed
61

62
63
-- * Constants

64
-- | The exclusion tag prefix.
65
66
67
exTagsPrefix :: String
exTagsPrefix = "htools:iextags:"

68
69
-- * Types

70
{-| The iallocator request type.
71
72
73
74
75
76

This type denotes what request we got from Ganeti and also holds
request-specific fields.

-}
data RqType
77
78
79
80
  = 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
81
    deriving (Show, Read)
82
83

-- | A complete request, as received from Ganeti.
84
data Request = Request RqType ClusterData
85
               deriving (Show, Read)
86

Iustin Pop's avatar
Iustin Pop committed
87
88
-- | The cluster state.
data ClusterData = ClusterData
89
90
91
92
  { cdGroups    :: Group.List    -- ^ The node group list
  , cdNodes     :: Node.List     -- ^ The node list
  , cdInstances :: Instance.List -- ^ The instance list
  , cdTags      :: [String]      -- ^ The cluster tags
93
  , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy
94
  } deriving (Show, Read, Eq)
Iustin Pop's avatar
Iustin Pop committed
95

96
97
98
99
100
101
102
103
104
-- | 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
105
106
107
108
  { lrMatchPriority :: MatchPriority -- ^ The result type
  -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
  , lrContent :: String
  } deriving (Show, Read)
109
110
111
112
113
114
115
116

-- | Lookup results have an absolute preference ordering.
instance Eq LookupResult where
  (==) = (==) `on` lrMatchPriority

instance Ord LookupResult where
  compare = compare `on` lrMatchPriority

Iustin Pop's avatar
Iustin Pop committed
117
118
119
-- | An empty cluster.
emptyCluster :: ClusterData
emptyCluster = ClusterData Container.empty Container.empty Container.empty []
120
                 defIPolicy
Iustin Pop's avatar
Iustin Pop committed
121

122
123
-- * Functions

Iustin Pop's avatar
Iustin Pop committed
124
-- | Lookups a node into an assoc list.
125
lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
Iustin Pop's avatar
Iustin Pop committed
126
lookupNode ktn inst node =
127
128
129
  case M.lookup node ktn of
    Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
    Just idx -> return idx
Iustin Pop's avatar
Iustin Pop committed
130

Iustin Pop's avatar
Iustin Pop committed
131
-- | Lookups an instance into an assoc list.
132
lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
133
lookupInstance kti inst =
134
135
136
  case M.lookup inst kti of
    Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
    Just idx -> return idx
137

Iustin Pop's avatar
Iustin Pop committed
138
139
140
-- | Lookups a group into an assoc list.
lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
lookupGroup ktg nname gname =
141
142
143
  case M.lookup gname ktg of
    Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
    Just idx -> return idx
Iustin Pop's avatar
Iustin Pop committed
144

145
146
147
148
149
150
-- | 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
151
prefixMatch = isPrefixOf . (++ ".")
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

-- | 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
183
  [ (lrMatchPriority new == ExactMatch, new)
184
185
186
187
188
189
190
191
192
193
194
195
  -- 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

Iustin Pop's avatar
Iustin Pop committed
196
-- | Given a list of elements (and their names), assign indices to them.
197
198
assignIndices :: (Element a) =>
                 [(String, a)]
199
              -> (NameAssoc, Container.Container a)
200
201
202
203
assignIndices nodes =
  let (na, idx_node) =
          unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
          . zip [0..] $ nodes
Iustin Pop's avatar
Iustin Pop committed
204
  in (M.fromList na, Container.fromList idx_node)
205

Iustin Pop's avatar
Iustin Pop committed
206
-- | For each instance, add its index to its primary and secondary nodes.
207
fixNodes :: Node.List
208
         -> Instance.Instance
209
         -> Node.List
210
fixNodes accu inst =
211
212
213
214
215
216
217
218
219
220
  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
Iustin Pop's avatar
Iustin Pop committed
221

Iustin Pop's avatar
Iustin Pop committed
222
223
224
225
226
227
228
229
230
-- | 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

231
-- | Remove non-selected tags from the exclusion list.
232
233
filterExTags :: [String] -> Instance.Instance -> Instance.Instance
filterExTags tl inst =
234
235
236
  let old_tags = Instance.tags inst
      new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) old_tags
  in inst { Instance.tags = new_tags }
237

238
-- | Update the movable attribute.
239
240
241
242
243
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 =
244
  if Instance.name inst `elem` exinsts ||
245
     not (null selinsts || Instance.name inst `elem` selinsts)
246
247
248
    then Instance.setMovable inst False
    else inst

Iustin Pop's avatar
Iustin Pop committed
249
-- | Compute the longest common suffix of a list of strings that
250
-- starts with a dot.
251
longestDomain :: [String] -> String
Iustin Pop's avatar
Iustin Pop committed
252
longestDomain [] = ""
253
longestDomain (x:xs) =
254
255
256
257
  foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
                            then suffix
                            else accu)
          "" $ filter (isPrefixOf ".") (tails x)
Iustin Pop's avatar
Iustin Pop committed
258

259
-- | Extracts the exclusion tags from the cluster configuration.
260
261
extractExTags :: [String] -> [String]
extractExTags =
262
263
  map (drop (length exTagsPrefix)) .
  filter (isPrefixOf exTagsPrefix)
264

265
-- | Extracts the common suffix from node\/instance names.
266
267
commonSuffix :: Node.List -> Instance.List -> String
commonSuffix nl il =
268
269
270
  let node_names = map Node.name $ Container.elems nl
      inst_names = map Instance.name $ Container.elems il
  in longestDomain (node_names ++ inst_names)
271

Iustin Pop's avatar
Iustin Pop committed
272
273
-- | Initializer function that loads the data from a node and instance
-- list and massages it into the correct format.
274
mergeData :: [(String, DynUtil)]  -- ^ Instance utilisation data
275
          -> [String]             -- ^ Exclusion tags
276
277
          -> [String]             -- ^ Selected instances (if not empty)
          -> [String]             -- ^ Excluded instances
278
          -> ClusterData          -- ^ Data from backends
279
          -> Result ClusterData   -- ^ Fixed cluster data
Iustin Pop's avatar
Iustin Pop committed
280
mergeData um extags selinsts exinsts cdata@(ClusterData gl nl il2 tags _) =
281
  let il = Container.elems il2
282
283
284
285
286
287
288
      il3 = foldl' (\im (name, n_util) ->
                        case Container.findByName im name of
                          Nothing -> im -- skipping unknown instance
                          Just inst ->
                              let new_i = inst { Instance.util = n_util }
                              in Container.add (Instance.idx inst) new_i im
                   ) il2 um
289
      allextags = extags ++ extractExTags tags
290
291
292
293
294
295
      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
296
      node_names = map Node.name (Container.elems nl)
297
      common_suffix = longestDomain (node_names ++ inst_names)
298
299
300
301
      il4 = Container.map (computeAlias common_suffix .
                           filterExTags allextags .
                           updateMovable selinst_names exinst_names) il3
      nl2 = foldl' fixNodes nl (Container.elems il4)
Iustin Pop's avatar
Iustin Pop committed
302
303
      nl3 = Container.map (setNodePolicy gl .
                           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))
308

Iustin Pop's avatar
Iustin Pop committed
309
-- | Checks the cluster data for consistency.
310
311
checkData :: Node.List -> Instance.List
          -> ([String], Node.List)
312
checkData nl il =
313
314
    Container.mapAccum
        (\ msgs node ->
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
320
321
                 delta_mem = truncate (Node.tMem node)
                             - Node.nMem node
                             - Node.fMem node
Iustin Pop's avatar
Iustin Pop committed
322
                             - nodeImem node il
323
                             + adj_mem
324
325
                 delta_dsk = truncate (Node.tDsk node)
                             - Node.fDsk node
Iustin Pop's avatar
Iustin Pop committed
326
                             - nodeIdsk node il
327
                 newn = Node.setFmem (Node.setXmem node delta_mem)
328
                        (Node.fMem node - adj_mem)
329
330
                 umsg1 =
                   if delta_mem > 512 || delta_dsk > 1024
Iustin Pop's avatar
Iustin Pop committed
331
332
333
                      then printf "node %s is missing %d MB ram \
                                  \and %d GB disk"
                                  nname delta_mem (delta_dsk `div` 1024):msgs
334
335
                      else msgs
             in (umsg1, newn)
336
337
338
        ) [] nl

-- | Compute the amount of memory used by primary instances on a node.
339
nodeImem :: Node.Node -> Instance.List -> Int
340
nodeImem node il =
341
342
  let rfind = flip Container.find il
      il' = map rfind $ Node.pList node
Iustin Pop's avatar
Iustin Pop committed
343
      oil' = filter Instance.notOffline il'
344
  in sum . map Instance.mem $ oil'
345

346
347
348

-- | Compute the amount of disk used by instances on a node (either primary
-- or secondary).
349
nodeIdsk :: Node.Node -> Instance.List -> Int
350
nodeIdsk node il =
351
352
353
  let rfind = flip Container.find il
  in sum . map (Instance.dsk . rfind)
       $ Node.pList node ++ Node.sList node