Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (12.5 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
  , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy
94
  } deriving (Show, Read)
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
-- | Remove non-selected tags from the exclusion list.
223
filterExTags :: [String] -> Instance.Instance -> Instance.Instance
224
filterExTags tl inst =
225
  let old_tags = Instance.tags inst
226
      new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) 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
      node_names = map Node.name (Container.elems nl)
289
      common_suffix = longestDomain (node_names ++ inst_names)
290
      il4 = Container.map (computeAlias common_suffix .
291
                           filterExTags allextags .
292
                           updateMovable selinst_names exinst_names) il3
293
      nl2 = foldl' fixNodes nl (Container.elems il4)
294
      nl3 = Container.map (computeAlias common_suffix .
295
                           (`Node.buildPeers` il4)) nl2
296
  in if' (null lkp_unknown)
297
         (Ok cdata { cdNodes = nl3, cdInstances = il4 })
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 Instance.instanceDown 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 =
321
                   if delta_mem > 512 || delta_dsk > 1024
322
                      then printf "node %s is missing %d MB ram \
323
                                  \and %d GB disk"
324
                                  nname delta_mem (delta_dsk `div` 1024):msgs
325
                      else msgs
326
             in (umsg1, newn)
327
        ) [] nl
328

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

    
337

    
338
-- | Compute the amount of disk used by instances on a node (either primary
339
-- or secondary).
340
nodeIdsk :: Node.Node -> Instance.List -> Int
341
nodeIdsk node il =
342
  let rfind = flip Container.find il
343
  in sum . map (Instance.dsk . rfind)
344
       $ Node.pList node ++ Node.sList node