Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / Loader.hs @ 1b0a6356

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