code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/HTools/Loader.hs

   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     , lookupNode
  34     , lookupInstance
  35     , lookupGroup
  36     , commonSuffix
  37     , RelocMode(..)
  38     , EvacMode(..)
  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 multi-evac group mode type.
  71 data RelocMode = KeepGroup
  72                | ChangeGroup [Gdx]
  73                | AnyGroup
  74                  deriving (Show, Read)
  75
  76 {-| The iallocator request type.
  77
  78 This type denotes what request we got from Ganeti and also holds
  79 request-specific fields.
  80
  81 -}
  82 data RqType
  83     = Allocate Instance.Instance Int -- ^ A new instance allocation
  84     | Relocate Idx Int [Ndx]         -- ^ Move an instance to a new
  85                                      -- secondary node
  86     | Evacuate [Ndx]                 -- ^ Evacuate nodes
  87     | MultiReloc [Idx] RelocMode     -- ^ Multi-relocate mode
  88     | NodeEvacuate [Idx] EvacMode    -- ^ node-evacuate mode
  89     deriving (Show, Read)
  90
  91 -- | A complete request, as received from Ganeti.
  92 data Request = Request RqType ClusterData
  93     deriving (Show, Read)
  94
  95 -- | The cluster state.
  96 data ClusterData = ClusterData
  97     { cdGroups    :: Group.List    -- ^ The node group list
  98     , cdNodes     :: Node.List     -- ^ The node list
  99     , cdInstances :: Instance.List -- ^ The instance list
 100     , cdTags      :: [String]      -- ^ The cluster tags
 101     } deriving (Show, Read)
 102
 103 -- | The priority of a match in a lookup result.
 104 data MatchPriority = ExactMatch
 105                    | MultipleMatch
 106                    | PartialMatch
 107                    | FailMatch
 108                    deriving (Show, Read, Enum, Eq, Ord)
 109
 110 -- | The result of a name lookup in a list.
 111 data LookupResult = LookupResult
 112     { lrMatchPriority :: MatchPriority -- ^ The result type
 113     -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
 114     , lrContent :: String
 115     } deriving (Show, Read)
 116
 117 -- | Lookup results have an absolute preference ordering.
 118 instance Eq LookupResult where
 119   (==) = (==) `on` lrMatchPriority
 120
 121 instance Ord LookupResult where
 122   compare = compare `on` lrMatchPriority
 123
 124 -- | An empty cluster.
 125 emptyCluster :: ClusterData
 126 emptyCluster = ClusterData Container.empty Container.empty Container.empty []
 127
 128 -- * Functions
 129
 130 -- | Lookups a node into an assoc list.
 131 lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
 132 lookupNode ktn inst node =
 133     case M.lookup node ktn of
 134       Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
 135       Just idx -> return idx
 136
 137 -- | Lookups an instance into an assoc list.
 138 lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
 139 lookupInstance kti inst =
 140     case M.lookup inst kti of
 141       Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
 142       Just idx -> return idx
 143
 144 -- | Lookups a group into an assoc list.
 145 lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
 146 lookupGroup ktg nname gname =
 147     case M.lookup gname ktg of
 148       Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
 149       Just idx -> return idx
 150
 151 -- | Check for prefix matches in names.
 152 -- Implemented in Ganeti core utils.text.MatchNameComponent
 153 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
 154 prefixMatch :: String  -- ^ Lookup
 155             -> String  -- ^ Full name
 156             -> Bool    -- ^ Whether there is a prefix match
 157 prefixMatch lkp = isPrefixOf (lkp ++ ".")
 158
 159 -- | Is the lookup priority a "good" one?
 160 goodMatchPriority :: MatchPriority -> Bool
 161 goodMatchPriority ExactMatch = True
 162 goodMatchPriority PartialMatch = True
 163 goodMatchPriority _ = False
 164
 165 -- | Is the lookup result an actual match?
 166 goodLookupResult :: LookupResult -> Bool
 167 goodLookupResult = goodMatchPriority . lrMatchPriority
 168
 169 -- | Compares a canonical name and a lookup string.
 170 compareNameComponent :: String        -- ^ Canonical (target) name
 171                      -> String        -- ^ Partial (lookup) name
 172                      -> LookupResult  -- ^ Result of the lookup
 173 compareNameComponent cnl lkp =
 174   select (LookupResult FailMatch lkp)
 175   [ (cnl == lkp          , LookupResult ExactMatch cnl)
 176   , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
 177   ]
 178
 179 -- | Lookup a string and choose the best result.
 180 chooseLookupResult :: String       -- ^ Lookup key
 181                    -> String       -- ^ String to compare to the lookup key
 182                    -> LookupResult -- ^ Previous result
 183                    -> LookupResult -- ^ New result
 184 chooseLookupResult lkp cstr old =
 185   -- default: use class order to pick the minimum result
 186   select (min new old)
 187   -- special cases:
 188   -- short circuit if the new result is an exact match
 189   [ ((lrMatchPriority new) == ExactMatch, new)
 190   -- if both are partial matches generate a multiple match
 191   , (partial2, LookupResult MultipleMatch lkp)
 192   ] where new = compareNameComponent cstr lkp
 193           partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
 194
 195 -- | Find the canonical name for a lookup string in a list of names.
 196 lookupName :: [String]      -- ^ List of keys
 197            -> String        -- ^ Lookup string
 198            -> LookupResult  -- ^ Result of the lookup
 199 lookupName l s = foldr (chooseLookupResult s)
 200                        (LookupResult FailMatch s) l
 201
 202 -- | Given a list of elements (and their names), assign indices to them.
 203 assignIndices :: (Element a) =>
 204                  [(String, a)]
 205               -> (NameAssoc, Container.Container a)
 206 assignIndices nodes =
 207   let (na, idx_node) =
 208           unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
 209           . zip [0..] $ nodes
 210   in (M.fromList na, Container.fromList idx_node)
 211
 212 -- | For each instance, add its index to its primary and secondary nodes.
 213 fixNodes :: Node.List
 214          -> Instance.Instance
 215          -> Node.List
 216 fixNodes accu inst =
 217     let
 218         pdx = Instance.pNode inst
 219         sdx = Instance.sNode inst
 220         pold = Container.find pdx accu
 221         pnew = Node.setPri pold inst
 222         ac2 = Container.add pdx pnew accu
 223     in
 224       if sdx /= Node.noSecondary
 225       then let sold = Container.find sdx accu
 226                snew = Node.setSec sold inst
 227            in Container.add sdx snew ac2
 228       else ac2
 229
 230 -- | Remove non-selected tags from the exclusion list.
 231 filterExTags :: [String] -> Instance.Instance -> Instance.Instance
 232 filterExTags tl inst =
 233     let old_tags = Instance.tags inst
 234         new_tags = filter (\tag -> any (`isPrefixOf` tag) tl)
 235                    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 _ 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       il4 = Container.map (filterExTags allextags .
 298                            updateMovable selinst_names exinst_names) il3
 299       nl2 = foldl' fixNodes nl (Container.elems il4)
 300       nl3 = Container.map (flip Node.buildPeers il4) nl2
 301       node_names = map Node.name (Container.elems nl)
 302       common_suffix = longestDomain (node_names ++ inst_names)
 303       snl = Container.map (computeAlias common_suffix) nl3
 304       sil = Container.map (computeAlias common_suffix) il4
 305   in if' (null lkp_unknown)
 306          (Ok cdata { cdNodes = snl, cdInstances = sil })
 307          (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))
 308
 309 -- | Checks the cluster data for consistency.
 310 checkData :: Node.List -> Instance.List
 311           -> ([String], Node.List)
 312 checkData nl il =
 313     Container.mapAccum
 314         (\ msgs node ->
 315              let nname = Node.name node
 316                  nilst = map (`Container.find` il) (Node.pList node)
 317                  dilst = filter (not . Instance.running) nilst
 318                  adj_mem = sum . map Instance.mem $ dilst
 319                  delta_mem = truncate (Node.tMem node)
 320                              - Node.nMem node
 321                              - Node.fMem node
 322                              - nodeImem node il
 323                              + adj_mem
 324                  delta_dsk = truncate (Node.tDsk node)
 325                              - Node.fDsk node
 326                              - nodeIdsk node il
 327                  newn = Node.setFmem (Node.setXmem node delta_mem)
 328                         (Node.fMem node - adj_mem)
 329                  umsg1 = [printf "node %s is missing %d MB ram \
 330                                  \and %d GB disk"
 331                                  nname delta_mem (delta_dsk `div` 1024) |
 332                                  delta_mem > 512 || delta_dsk > 1024]::[String]
 333              in (msgs ++ umsg1, newn)
 334         ) [] nl
 335
 336 -- | Compute the amount of memory used by primary instances on a node.
 337 nodeImem :: Node.Node -> Instance.List -> Int
 338 nodeImem node il =
 339     let rfind = flip Container.find il
 340     in sum . map (Instance.mem . rfind)
 341            $ Node.pList node
 342
 343 -- | Compute the amount of disk used by instances on a node (either primary
 344 -- or secondary).
 345 nodeIdsk :: Node.Node -> Instance.List -> Int
 346 nodeIdsk node il =
 347     let rfind = flip Container.find il
 348     in sum . map (Instance.dsk . rfind)
 349            $ Node.pList node ++ Node.sList node