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   , lookupNode
  34   , lookupInstance
  35   , lookupGroup
  36   , commonSuffix
  37   , RqType(..)
  38   , Request(..)
  39   , ClusterData(..)
  40   , emptyCluster
  41   ) where
  42
  43 import Data.List
  44 import qualified Data.Map as M
  45 import Text.Printf (printf)
  46
  47 import qualified Ganeti.HTools.Container as Container
  48 import qualified Ganeti.HTools.Instance as Instance
  49 import qualified Ganeti.HTools.Node as Node
  50 import qualified Ganeti.HTools.Group as Group
  51 import qualified Ganeti.HTools.Cluster as Cluster
  52
  53 import Ganeti.BasicTypes
  54 import Ganeti.HTools.Types
  55 import Ganeti.HTools.Utils
  56
  57 -- * Constants
  58
  59 -- | The exclusion tag prefix.
  60 exTagsPrefix :: String
  61 exTagsPrefix = "htools:iextags:"
  62
  63 -- * Types
  64
  65 {-| The iallocator request type.
  66
  67 This type denotes what request we got from Ganeti and also holds
  68 request-specific fields.
  69
  70 -}
  71 data RqType
  72   = Allocate Instance.Instance Int           -- ^ A new instance allocation
  73   | Relocate Idx Int [Ndx]                   -- ^ Choose a new secondary node
  74   | NodeEvacuate [Idx] EvacMode              -- ^ node-evacuate mode
  75   | ChangeGroup [Gdx] [Idx]                  -- ^ Multi-relocate mode
  76   | MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode
  77     deriving (Show, Read)
  78
  79 -- | A complete request, as received from Ganeti.
  80 data Request = Request RqType ClusterData
  81                deriving (Show, Read)
  82
  83 -- | The cluster state.
  84 data ClusterData = ClusterData
  85   { cdGroups    :: Group.List    -- ^ The node group list
  86   , cdNodes     :: Node.List     -- ^ The node list
  87   , cdInstances :: Instance.List -- ^ The instance list
  88   , cdTags      :: [String]      -- ^ The cluster tags
  89   , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy
  90   } deriving (Show, Read, Eq)
  91
  92 -- | An empty cluster.
  93 emptyCluster :: ClusterData
  94 emptyCluster = ClusterData Container.empty Container.empty Container.empty []
  95                  defIPolicy
  96
  97 -- * Functions
  98
  99 -- | Lookups a node into an assoc list.
 100 lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
 101 lookupNode ktn inst node =
 102   maybe (fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst) return $
 103     M.lookup node ktn
 104
 105 -- | Lookups an instance into an assoc list.
 106 lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
 107 lookupInstance kti inst =
 108   maybe (fail $ "Unknown instance '" ++ inst ++ "'") return $ M.lookup inst kti
 109
 110 -- | Lookups a group into an assoc list.
 111 lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
 112 lookupGroup ktg nname gname =
 113   maybe (fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname) return $
 114     M.lookup gname ktg
 115
 116 -- | Given a list of elements (and their names), assign indices to them.
 117 assignIndices :: (Element a) =>
 118                  [(String, a)]
 119               -> (NameAssoc, Container.Container a)
 120 assignIndices nodes =
 121   let (na, idx_node) =
 122           unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
 123           . zip [0..] $ nodes
 124   in (M.fromList na, Container.fromList idx_node)
 125
 126 -- | For each instance, add its index to its primary and secondary nodes.
 127 fixNodes :: Node.List
 128          -> Instance.Instance
 129          -> Node.List
 130 fixNodes accu inst =
 131   let pdx = Instance.pNode inst
 132       sdx = Instance.sNode inst
 133       pold = Container.find pdx accu
 134       pnew = Node.setPri pold inst
 135       ac2 = Container.add pdx pnew accu
 136   in if sdx /= Node.noSecondary
 137        then let sold = Container.find sdx accu
 138                 snew = Node.setSec sold inst
 139             in Container.add sdx snew ac2
 140        else ac2
 141
 142 -- | Set the node's policy to its group one. Note that this requires
 143 -- the group to exist (should have been checked before), otherwise it
 144 -- will abort with a runtime error.
 145 setNodePolicy :: Group.List -> Node.Node -> Node.Node
 146 setNodePolicy gl node =
 147   let grp = Container.find (Node.group node) gl
 148       gpol = Group.iPolicy grp
 149   in Node.setPolicy gpol node
 150
 151 -- | Remove non-selected tags from the exclusion list.
 152 filterExTags :: [String] -> Instance.Instance -> Instance.Instance
 153 filterExTags tl inst =
 154   let old_tags = Instance.tags inst
 155       new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) old_tags
 156   in inst { Instance.tags = new_tags }
 157
 158 -- | Update the movable attribute.
 159 updateMovable :: [String]           -- ^ Selected instances (if not empty)
 160               -> [String]           -- ^ Excluded instances
 161               -> Instance.Instance  -- ^ Target Instance
 162               -> Instance.Instance  -- ^ Target Instance with updated attribute
 163 updateMovable selinsts exinsts inst =
 164   if Instance.name inst `elem` exinsts ||
 165      not (null selinsts || Instance.name inst `elem` selinsts)
 166     then Instance.setMovable inst False
 167     else inst
 168
 169 -- | Disables moves for instances with a split group.
 170 disableSplitMoves :: Node.List -> Instance.Instance -> Instance.Instance
 171 disableSplitMoves nl inst =
 172   if not . isOk . Cluster.instanceGroup nl $ inst
 173     then Instance.setMovable inst False
 174     else inst
 175
 176 -- | Compute the longest common suffix of a list of strings that
 177 -- starts with a dot.
 178 longestDomain :: [String] -> String
 179 longestDomain [] = ""
 180 longestDomain (x:xs) =
 181   foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
 182                             then suffix
 183                             else accu)
 184           "" $ filter (isPrefixOf ".") (tails x)
 185
 186 -- | Extracts the exclusion tags from the cluster configuration.
 187 extractExTags :: [String] -> [String]
 188 extractExTags =
 189   map (drop (length exTagsPrefix)) .
 190   filter (isPrefixOf exTagsPrefix)
 191
 192 -- | Extracts the common suffix from node\/instance names.
 193 commonSuffix :: Node.List -> Instance.List -> String
 194 commonSuffix nl il =
 195   let node_names = map Node.name $ Container.elems nl
 196       inst_names = map Instance.name $ Container.elems il
 197   in longestDomain (node_names ++ inst_names)
 198
 199 -- | Initializer function that loads the data from a node and instance
 200 -- list and massages it into the correct format.
 201 mergeData :: [(String, DynUtil)]  -- ^ Instance utilisation data
 202           -> [String]             -- ^ Exclusion tags
 203           -> [String]             -- ^ Selected instances (if not empty)
 204           -> [String]             -- ^ Excluded instances
 205           -> ClusterData          -- ^ Data from backends
 206           -> Result ClusterData   -- ^ Fixed cluster data
 207 mergeData um extags selinsts exinsts cdata@(ClusterData gl nl il2 tags _) =
 208   let il = Container.elems il2
 209       il3 = foldl' (\im (name, n_util) ->
 210                         case Container.findByName im name of
 211                           Nothing -> im -- skipping unknown instance
 212                           Just inst ->
 213                               let new_i = inst { Instance.util = n_util }
 214                               in Container.add (Instance.idx inst) new_i im
 215                    ) il2 um
 216       allextags = extags ++ extractExTags tags
 217       inst_names = map Instance.name il
 218       selinst_lkp = map (lookupName inst_names) selinsts
 219       exinst_lkp = map (lookupName inst_names) exinsts
 220       lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
 221       selinst_names = map lrContent selinst_lkp
 222       exinst_names = map lrContent exinst_lkp
 223       node_names = map Node.name (Container.elems nl)
 224       common_suffix = longestDomain (node_names ++ inst_names)
 225       il4 = Container.map (computeAlias common_suffix .
 226                            filterExTags allextags .
 227                            updateMovable selinst_names exinst_names) il3
 228       nl2 = foldl' fixNodes nl (Container.elems il4)
 229       nl3 = Container.map (setNodePolicy gl .
 230                            computeAlias common_suffix .
 231                            (`Node.buildPeers` il4)) nl2
 232       il5 = Container.map (disableSplitMoves nl3) il4
 233   in if' (null lkp_unknown)
 234          (Ok cdata { cdNodes = nl3, cdInstances = il5 })
 235          (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))
 236
 237 -- | Checks the cluster data for consistency.
 238 checkData :: Node.List -> Instance.List
 239           -> ([String], Node.List)
 240 checkData nl il =
 241     Container.mapAccum
 242         (\ msgs node ->
 243              let nname = Node.name node
 244                  nilst = map (`Container.find` il) (Node.pList node)
 245                  dilst = filter Instance.instanceDown nilst
 246                  adj_mem = sum . map Instance.mem $ dilst
 247                  delta_mem = truncate (Node.tMem node)
 248                              - Node.nMem node
 249                              - Node.fMem node
 250                              - nodeImem node il
 251                              + adj_mem
 252                  delta_dsk = truncate (Node.tDsk node)
 253                              - Node.fDsk node
 254                              - nodeIdsk node il
 255                  newn = Node.setFmem (Node.setXmem node delta_mem)
 256                         (Node.fMem node - adj_mem)
 257                  umsg1 =
 258                    if delta_mem > 512 || delta_dsk > 1024
 259                       then printf "node %s is missing %d MB ram \
 260                                   \and %d GB disk"
 261                                   nname delta_mem (delta_dsk `div` 1024):msgs
 262                       else msgs
 263              in (umsg1, newn)
 264         ) [] nl
 265
 266 -- | Compute the amount of memory used by primary instances on a node.
 267 nodeImem :: Node.Node -> Instance.List -> Int
 268 nodeImem node il =
 269   let rfind = flip Container.find il
 270       il' = map rfind $ Node.pList node
 271       oil' = filter Instance.notOffline il'
 272   in sum . map Instance.mem $ oil'
 273
 274
 275 -- | Compute the amount of disk used by instances on a node (either primary
 276 -- or secondary).
 277 nodeIdsk :: Node.Node -> Instance.List -> Int
 278 nodeIdsk node il =
 279   let rfind = flip Container.find il
 280   in sum . map (Instance.dsk . rfind)
 281        $ Node.pList node ++ Node.sList node