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