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, 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