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