Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / Loader.hs @ 7959cbb9

History | View | Annotate | Download (12.9 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, 2012 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
  | Relocate Idx Int [Ndx]         -- ^ Choose a new secondary node
79
  | NodeEvacuate [Idx] EvacMode    -- ^ node-evacuate mode
80
  | 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

    
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)
95

    
96
-- | The priority of a match in a lookup result.
97
data MatchPriority = ExactMatch
98
                   | MultipleMatch
99
                   | PartialMatch
100
                   | FailMatch
101
                   deriving (Show, Read, Enum, Eq, Ord)
102

    
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)
109

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

    
114
instance Ord LookupResult where
115
  compare = compare `on` lrMatchPriority
116

    
117
-- | An empty cluster.
118
emptyCluster :: ClusterData
119
emptyCluster = ClusterData Container.empty Container.empty Container.empty []
120
                 defIPolicy
121

    
122
-- * Functions
123

    
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
130

    
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
137

    
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
144

    
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 . (++ ".")
152

    
153
-- | Is the lookup priority a "good" one?
154
goodMatchPriority :: MatchPriority -> Bool
155
goodMatchPriority ExactMatch = True
156
goodMatchPriority PartialMatch = True
157
goodMatchPriority _ = False
158

    
159
-- | Is the lookup result an actual match?
160
goodLookupResult :: LookupResult -> Bool
161
goodLookupResult = goodMatchPriority . lrMatchPriority
162

    
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)
171
  ]
172

    
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
180
  select (min new old)
181
  -- special cases:
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]
188

    
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
195

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

    
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
  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
220
       else ac2
221

    
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
230

    
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 }
237

    
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.sNode inst == Node.noSecondary ||
245
     Instance.name inst `elem` exinsts ||
246
     not (null selinsts || Instance.name inst `elem` selinsts)
247
    then Instance.setMovable inst False
248
    else inst
249

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

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

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

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

    
310
-- | Checks the cluster data for consistency.
311
checkData :: Node.List -> Instance.List
312
          -> ([String], Node.List)
313
checkData nl il =
314
    Container.mapAccum
315
        (\ msgs node ->
316
             let nname = Node.name node
317
                 nilst = map (`Container.find` il) (Node.pList node)
318
                 dilst = filter Instance.instanceDown nilst
319
                 adj_mem = sum . map Instance.mem $ dilst
320
                 delta_mem = truncate (Node.tMem node)
321
                             - Node.nMem node
322
                             - Node.fMem node
323
                             - nodeImem node il
324
                             + adj_mem
325
                 delta_dsk = truncate (Node.tDsk node)
326
                             - Node.fDsk node
327
                             - nodeIdsk node il
328
                 newn = Node.setFmem (Node.setXmem node delta_mem)
329
                        (Node.fMem node - adj_mem)
330
                 umsg1 =
331
                   if delta_mem > 512 || delta_dsk > 1024
332
                      then printf "node %s is missing %d MB ram \
333
                                  \and %d GB disk"
334
                                  nname delta_mem (delta_dsk `div` 1024):msgs
335
                      else msgs
336
             in (umsg1, newn)
337
        ) [] nl
338

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

    
347

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