Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / Loader.hs @ ebf38064

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
  | 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
  } deriving (Show, Read)
94

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

    
102
-- | The result of a name lookup in a list.
103
data LookupResult = LookupResult
104
  { lrMatchPriority :: MatchPriority -- ^ The result type
105
  -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
106
  , lrContent :: String
107
  } deriving (Show, Read)
108

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

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

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

    
120
-- * Functions
121

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

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

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

    
143
-- | Check for prefix matches in names.
144
-- Implemented in Ganeti core utils.text.MatchNameComponent
145
-- as the regexp r"^%s(\..*)?$" % re.escape(key)
146
prefixMatch :: String  -- ^ Lookup
147
            -> String  -- ^ Full name
148
            -> Bool    -- ^ Whether there is a prefix match
149
prefixMatch = isPrefixOf . (++ ".")
150

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

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

    
161
-- | Compares a canonical name and a lookup string.
162
compareNameComponent :: String        -- ^ Canonical (target) name
163
                     -> String        -- ^ Partial (lookup) name
164
                     -> LookupResult  -- ^ Result of the lookup
165
compareNameComponent cnl lkp =
166
  select (LookupResult FailMatch lkp)
167
  [ (cnl == lkp          , LookupResult ExactMatch cnl)
168
  , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
169
  ]
170

    
171
-- | Lookup a string and choose the best result.
172
chooseLookupResult :: String       -- ^ Lookup key
173
                   -> String       -- ^ String to compare to the lookup key
174
                   -> LookupResult -- ^ Previous result
175
                   -> LookupResult -- ^ New result
176
chooseLookupResult lkp cstr old =
177
  -- default: use class order to pick the minimum result
178
  select (min new old)
179
  -- special cases:
180
  -- short circuit if the new result is an exact match
181
  [ (lrMatchPriority new == ExactMatch, new)
182
  -- if both are partial matches generate a multiple match
183
  , (partial2, LookupResult MultipleMatch lkp)
184
  ] where new = compareNameComponent cstr lkp
185
          partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
186

    
187
-- | Find the canonical name for a lookup string in a list of names.
188
lookupName :: [String]      -- ^ List of keys
189
           -> String        -- ^ Lookup string
190
           -> LookupResult  -- ^ Result of the lookup
191
lookupName l s = foldr (chooseLookupResult s)
192
                       (LookupResult FailMatch s) l
193

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

    
204
-- | For each instance, add its index to its primary and secondary nodes.
205
fixNodes :: Node.List
206
         -> Instance.Instance
207
         -> Node.List
208
fixNodes accu inst =
209
  let 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 if sdx /= Node.noSecondary
215
       then let sold = Container.find sdx accu
216
                snew = Node.setSec sold inst
217
            in Container.add sdx snew ac2
218
       else ac2
219

    
220
-- | Remove non-selected tags from the exclusion list.
221
filterExTags :: [String] -> Instance.Instance -> Instance.Instance
222
filterExTags tl inst =
223
  let old_tags = Instance.tags inst
224
      new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) old_tags
225
  in inst { Instance.tags = new_tags }
226

    
227
-- | Update the movable attribute.
228
updateMovable :: [String]           -- ^ Selected instances (if not empty)
229
              -> [String]           -- ^ Excluded instances
230
              -> Instance.Instance  -- ^ Target Instance
231
              -> Instance.Instance  -- ^ Target Instance with updated attribute
232
updateMovable selinsts exinsts inst =
233
  if Instance.sNode inst == Node.noSecondary ||
234
     Instance.name inst `elem` exinsts ||
235
     not (null selinsts || Instance.name inst `elem` selinsts)
236
    then Instance.setMovable inst False
237
    else inst
238

    
239
-- | Compute the longest common suffix of a list of strings that
240
-- starts with a dot.
241
longestDomain :: [String] -> String
242
longestDomain [] = ""
243
longestDomain (x:xs) =
244
  foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
245
                            then suffix
246
                            else accu)
247
          "" $ filter (isPrefixOf ".") (tails x)
248

    
249
-- | Extracts the exclusion tags from the cluster configuration.
250
extractExTags :: [String] -> [String]
251
extractExTags =
252
  map (drop (length exTagsPrefix)) .
253
  filter (isPrefixOf exTagsPrefix)
254

    
255
-- | Extracts the common suffix from node\/instance names.
256
commonSuffix :: Node.List -> Instance.List -> String
257
commonSuffix nl il =
258
  let node_names = map Node.name $ Container.elems nl
259
      inst_names = map Instance.name $ Container.elems il
260
  in longestDomain (node_names ++ inst_names)
261

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

    
298
-- | Checks the cluster data for consistency.
299
checkData :: Node.List -> Instance.List
300
          -> ([String], Node.List)
301
checkData nl il =
302
    Container.mapAccum
303
        (\ msgs node ->
304
             let nname = Node.name node
305
                 nilst = map (`Container.find` il) (Node.pList node)
306
                 dilst = filter Instance.instanceDown nilst
307
                 adj_mem = sum . map Instance.mem $ dilst
308
                 delta_mem = truncate (Node.tMem node)
309
                             - Node.nMem node
310
                             - Node.fMem node
311
                             - nodeImem node il
312
                             + adj_mem
313
                 delta_dsk = truncate (Node.tDsk node)
314
                             - Node.fDsk node
315
                             - nodeIdsk node il
316
                 newn = Node.setFmem (Node.setXmem node delta_mem)
317
                        (Node.fMem node - adj_mem)
318
                 umsg1 = [printf "node %s is missing %d MB ram \
319
                                 \and %d GB disk"
320
                                 nname delta_mem (delta_dsk `div` 1024) |
321
                                 delta_mem > 512 || delta_dsk > 1024]::[String]
322
             in (msgs ++ umsg1, newn)
323
        ) [] nl
324

    
325
-- | Compute the amount of memory used by primary instances on a node.
326
nodeImem :: Node.Node -> Instance.List -> Int
327
nodeImem node il =
328
  let rfind = flip Container.find il
329
      il' = map rfind $ Node.pList node
330
      oil' = filter (not . Instance.instanceOffline) il'
331
  in sum . map Instance.mem $ oil'
332

    
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