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     , RqType(..)
  38     , Request(..)
  39     , ClusterData(..)
  40     , emptyCluster
  41     , compareNameComponent
  42     , prefixMatch
  43     , LookupResult(..)
  44     , MatchPriority(..)
  45     ) where
  46
  47 import Data.List
  48 import Data.Function
  49 import qualified Data.Map as M
  50 import Text.Printf (printf)
  51
  52 import qualified Ganeti.HTools.Container as Container
  53 import qualified Ganeti.HTools.Instance as Instance
  54 import qualified Ganeti.HTools.Node as Node
  55 import qualified Ganeti.HTools.Group as Group
  56
  57 import Ganeti.HTools.Types
  58 import Ganeti.HTools.Utils
  59
  60 -- * Constants
  61
  62 -- | The exclusion tag prefix.
  63 exTagsPrefix :: String
  64 exTagsPrefix = "htools:iextags:"
  65
  66 -- * Types
  67
  68 {-| The iallocator request type.
  69
  70 This type denotes what request we got from Ganeti and also holds
  71 request-specific fields.
  72
  73 -}
  74 data RqType
  75     = Allocate Instance.Instance Int -- ^ A new instance allocation
  76     | Relocate Idx Int [Ndx]         -- ^ Move an instance to a new
  77                                      -- secondary node
  78     | Evacuate [Ndx]                 -- ^ Evacuate nodes
  79     | ChangeGroup [Gdx] [Idx]        -- ^ Multi-relocate mode
  80     | NodeEvacuate [Idx] EvacMode    -- ^ node-evacuate 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 lkp = isPrefixOf (lkp ++ ".")
 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
 210         pdx = Instance.pNode inst
 211         sdx = Instance.sNode inst
 212         pold = Container.find pdx accu
 213         pnew = Node.setPri pold inst
 214         ac2 = Container.add pdx pnew accu
 215     in
 216       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)
 227                    old_tags
 228     in inst { Instance.tags = new_tags }
 229
 230 -- | Update the movable attribute.
 231 updateMovable :: [String]           -- ^ Selected instances (if not empty)
 232               -> [String]           -- ^ Excluded instances
 233               -> Instance.Instance  -- ^ Target Instance
 234               -> Instance.Instance  -- ^ Target Instance with updated attribute
 235 updateMovable selinsts exinsts inst =
 236     if Instance.sNode inst == Node.noSecondary ||
 237        Instance.name inst `elem` exinsts ||
 238        not (null selinsts || Instance.name inst `elem` selinsts)
 239     then Instance.setMovable inst False
 240     else inst
 241
 242 -- | Compute the longest common suffix of a list of strings that
 243 -- starts with a dot.
 244 longestDomain :: [String] -> String
 245 longestDomain [] = ""
 246 longestDomain (x:xs) =
 247       foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
 248                               then suffix
 249                               else accu)
 250       "" $ filter (isPrefixOf ".") (tails x)
 251
 252 -- | Extracts the exclusion tags from the cluster configuration.
 253 extractExTags :: [String] -> [String]
 254 extractExTags =
 255     map (drop (length exTagsPrefix)) .
 256     filter (isPrefixOf exTagsPrefix)
 257
 258 -- | Extracts the common suffix from node\/instance names.
 259 commonSuffix :: Node.List -> Instance.List -> String
 260 commonSuffix nl il =
 261     let node_names = map Node.name $ Container.elems nl
 262         inst_names = map Instance.name $ Container.elems il
 263     in longestDomain (node_names ++ inst_names)
 264
 265 -- | Initializer function that loads the data from a node and instance
 266 -- list and massages it into the correct format.
 267 mergeData :: [(String, DynUtil)]  -- ^ Instance utilisation data
 268           -> [String]             -- ^ Exclusion tags
 269           -> [String]             -- ^ Selected instances (if not empty)
 270           -> [String]             -- ^ Excluded instances
 271           -> ClusterData          -- ^ Data from backends
 272           -> Result ClusterData   -- ^ Fixed cluster data
 273 mergeData um extags selinsts exinsts cdata@(ClusterData _ nl il2 tags) =
 274   let il = Container.elems il2
 275       il3 = foldl' (\im (name, n_util) ->
 276                         case Container.findByName im name of
 277                           Nothing -> im -- skipping unknown instance
 278                           Just inst ->
 279                               let new_i = inst { Instance.util = n_util }
 280                               in Container.add (Instance.idx inst) new_i im
 281                    ) il2 um
 282       allextags = extags ++ extractExTags tags
 283       inst_names = map Instance.name il
 284       selinst_lkp = map (lookupName inst_names) selinsts
 285       exinst_lkp = map (lookupName inst_names) exinsts
 286       lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
 287       selinst_names = map lrContent selinst_lkp
 288       exinst_names = map lrContent exinst_lkp
 289       il4 = Container.map (filterExTags allextags .
 290                            updateMovable selinst_names exinst_names) il3
 291       nl2 = foldl' fixNodes nl (Container.elems il4)
 292       nl3 = Container.map (flip Node.buildPeers il4) nl2
 293       node_names = map Node.name (Container.elems nl)
 294       common_suffix = longestDomain (node_names ++ inst_names)
 295       snl = Container.map (computeAlias common_suffix) nl3
 296       sil = Container.map (computeAlias common_suffix) il4
 297   in if' (null lkp_unknown)
 298          (Ok cdata { cdNodes = snl, cdInstances = sil })
 299          (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))
 300
 301 -- | Checks the cluster data for consistency.
 302 checkData :: Node.List -> Instance.List
 303           -> ([String], Node.List)
 304 checkData nl il =
 305     Container.mapAccum
 306         (\ msgs node ->
 307              let nname = Node.name node
 308                  nilst = map (`Container.find` il) (Node.pList node)
 309                  dilst = filter (not . Instance.running) nilst
 310                  adj_mem = sum . map Instance.mem $ dilst
 311                  delta_mem = truncate (Node.tMem node)
 312                              - Node.nMem node
 313                              - Node.fMem node
 314                              - nodeImem node il
 315                              + adj_mem
 316                  delta_dsk = truncate (Node.tDsk node)
 317                              - Node.fDsk node
 318                              - nodeIdsk node il
 319                  newn = Node.setFmem (Node.setXmem node delta_mem)
 320                         (Node.fMem node - adj_mem)
 321                  umsg1 = [printf "node %s is missing %d MB ram \
 322                                  \and %d GB disk"
 323                                  nname delta_mem (delta_dsk `div` 1024) |
 324                                  delta_mem > 512 || delta_dsk > 1024]::[String]
 325              in (msgs ++ umsg1, newn)
 326         ) [] nl
 327
 328 -- | Compute the amount of memory used by primary instances on a node.
 329 nodeImem :: Node.Node -> Instance.List -> Int
 330 nodeImem node il =
 331     let rfind = flip Container.find il
 332     in sum . map (Instance.mem . rfind)
 333            $ Node.pList node
 334
 335 -- | Compute the amount of disk used by instances on a node (either primary
 336 -- or secondary).
 337 nodeIdsk :: Node.Node -> Instance.List -> Int
 338 nodeIdsk node il =
 339     let rfind = flip Container.find il
 340     in sum . map (Instance.dsk . rfind)
 341            $ Node.pList node ++ Node.sList node