code.grnet.gr Git - ganeti-local/blob - src/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   , clearDynU
  32   , checkData
  33   , assignIndices
  34   , setMaster
  35   , lookupNode
  36   , lookupInstance
  37   , lookupGroup
  38   , eitherLive
  39   , commonSuffix
  40   , RqType(..)
  41   , Request(..)
  42   , ClusterData(..)
  43   , emptyCluster
  44   ) where
  45
  46 import Control.Monad
  47 import Data.List
  48 import qualified Data.Map as M
  49 import Data.Maybe
  50 import Text.Printf (printf)
  51 import System.Time (ClockTime(..))
  52
  53 import qualified Ganeti.HTools.Container as Container
  54 import qualified Ganeti.HTools.Instance as Instance
  55 import qualified Ganeti.HTools.Node as Node
  56 import qualified Ganeti.HTools.Group as Group
  57 import qualified Ganeti.HTools.Cluster as Cluster
  58
  59 import Ganeti.BasicTypes
  60 import qualified Ganeti.Constants as C
  61 import Ganeti.HTools.Types
  62 import Ganeti.Utils
  63 import Ganeti.Types (EvacMode)
  64
  65 -- * Constants
  66
  67 -- | The exclusion tag prefix.
  68 exTagsPrefix :: String
  69 exTagsPrefix = "htools:iextags:"
  70
  71 -- * Types
  72
  73 {-| The iallocator request type.
  74
  75 This type denotes what request we got from Ganeti and also holds
  76 request-specific fields.
  77
  78 -}
  79 data RqType
  80   = Allocate Instance.Instance Int           -- ^ A new instance allocation
  81   | Relocate Idx Int [Ndx]                   -- ^ Choose a new secondary node
  82   | NodeEvacuate [Idx] EvacMode              -- ^ node-evacuate mode
  83   | ChangeGroup [Gdx] [Idx]                  -- ^ Multi-relocate mode
  84   | MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode
  85     deriving (Show)
  86
  87 -- | A complete request, as received from Ganeti.
  88 data Request = Request RqType ClusterData
  89                deriving (Show)
  90
  91 -- | The cluster state.
  92 data ClusterData = ClusterData
  93   { cdGroups    :: Group.List    -- ^ The node group list
  94   , cdNodes     :: Node.List     -- ^ The node list
  95   , cdInstances :: Instance.List -- ^ The instance list
  96   , cdTags      :: [String]      -- ^ The cluster tags
  97   , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy
  98   } deriving (Show, Eq)
  99
 100 -- | An empty cluster.
 101 emptyCluster :: ClusterData
 102 emptyCluster = ClusterData Container.empty Container.empty Container.empty []
 103                  defIPolicy
 104
 105 -- * Functions
 106
 107 -- | Lookups a node into an assoc list.
 108 lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
 109 lookupNode ktn inst node =
 110   maybe (fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst) return $
 111     M.lookup node ktn
 112
 113 -- | Lookups an instance into an assoc list.
 114 lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
 115 lookupInstance kti inst =
 116   maybe (fail $ "Unknown instance '" ++ inst ++ "'") return $ M.lookup inst kti
 117
 118 -- | Lookups a group into an assoc list.
 119 lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
 120 lookupGroup ktg nname gname =
 121   maybe (fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname) return $
 122     M.lookup gname ktg
 123
 124 -- | Given a list of elements (and their names), assign indices to them.
 125 assignIndices :: (Element a) =>
 126                  [(String, a)]
 127               -> (NameAssoc, Container.Container a)
 128 assignIndices name_element =
 129   let (name_idx, idx_element) =
 130           unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
 131           . zip [0..] $ name_element
 132   in (M.fromList name_idx, Container.fromList idx_element)
 133
 134 -- | Given am indexed node list, and the name of the master, mark it as such.
 135 setMaster :: (Monad m) => NameAssoc -> Node.List -> String -> m Node.List
 136 setMaster node_names node_idx master = do
 137   kmaster <- maybe (fail $ "Master node " ++ master ++ " unknown") return $
 138              M.lookup master node_names
 139   let mnode = Container.find kmaster node_idx
 140   return $ Container.add kmaster (Node.setMaster mnode True) node_idx
 141
 142 -- | For each instance, add its index to its primary and secondary nodes.
 143 fixNodes :: Node.List
 144          -> Instance.Instance
 145          -> Node.List
 146 fixNodes accu inst =
 147   let pdx = Instance.pNode inst
 148       sdx = Instance.sNode inst
 149       pold = Container.find pdx accu
 150       pnew = Node.setPri pold inst
 151       ac2 = Container.add pdx pnew accu
 152   in if sdx /= Node.noSecondary
 153        then let sold = Container.find sdx accu
 154                 snew = Node.setSec sold inst
 155             in Container.add sdx snew ac2
 156        else ac2
 157
 158 -- | Set the node's policy to its group one. Note that this requires
 159 -- the group to exist (should have been checked before), otherwise it
 160 -- will abort with a runtime error.
 161 setNodePolicy :: Group.List -> Node.Node -> Node.Node
 162 setNodePolicy gl node =
 163   let grp = Container.find (Node.group node) gl
 164       gpol = Group.iPolicy grp
 165   in Node.setPolicy gpol node
 166
 167 -- | Update instance with exclusion tags list.
 168 updateExclTags :: [String] -> Instance.Instance -> Instance.Instance
 169 updateExclTags tl inst =
 170   let allTags = Instance.allTags inst
 171       exclTags = filter (\tag -> any (`isPrefixOf` tag) tl) allTags
 172   in inst { Instance.exclTags = exclTags }
 173
 174 -- | Update the movable attribute.
 175 updateMovable :: [String]           -- ^ Selected instances (if not empty)
 176               -> [String]           -- ^ Excluded instances
 177               -> Instance.Instance  -- ^ Target Instance
 178               -> Instance.Instance  -- ^ Target Instance with updated attribute
 179 updateMovable selinsts exinsts inst =
 180   if Instance.name inst `elem` exinsts ||
 181      not (null selinsts || Instance.name inst `elem` selinsts)
 182     then Instance.setMovable inst False
 183     else inst
 184
 185 -- | Disables moves for instances with a split group.
 186 disableSplitMoves :: Node.List -> Instance.Instance -> Instance.Instance
 187 disableSplitMoves nl inst =
 188   if not . isOk . Cluster.instanceGroup nl $ inst
 189     then Instance.setMovable inst False
 190     else inst
 191
 192 -- | Set the auto-repair policy for an instance.
 193 setArPolicy :: [String]       -- ^ Cluster tags
 194             -> Group.List     -- ^ List of node groups
 195             -> Node.List      -- ^ List of nodes
 196             -> Instance.List  -- ^ List of instances
 197             -> ClockTime      -- ^ Current timestamp, to evaluate ArSuspended
 198             -> Instance.List  -- ^ Updated list of instances
 199 setArPolicy ctags gl nl il time =
 200   let getArPolicy' = flip getArPolicy time
 201       cpol = fromMaybe ArNotEnabled $ getArPolicy' ctags
 202       gpols = Container.map (fromMaybe cpol . getArPolicy' . Group.allTags) gl
 203       ipolfn = getArPolicy' . Instance.allTags
 204       nlookup = flip Container.find nl . Instance.pNode
 205       glookup = flip Container.find gpols . Node.group . nlookup
 206       updateInstance inst = inst {
 207         Instance.arPolicy = fromMaybe (glookup inst) $ ipolfn inst }
 208   in
 209    Container.map updateInstance il
 210
 211 -- | Get the auto-repair policy from a list of tags.
 212 --
 213 -- This examines the ganeti:watcher:autorepair and
 214 -- ganeti:watcher:autorepair:suspend tags to determine the policy. If none of
 215 -- these tags are present, Nothing (and not ArNotEnabled) is returned.
 216 getArPolicy :: [String] -> ClockTime -> Maybe AutoRepairPolicy
 217 getArPolicy tags time =
 218   let enabled = mapMaybe (autoRepairTypeFromRaw <=<
 219                           chompPrefix C.autoRepairTagEnabled) tags
 220       suspended = mapMaybe (chompPrefix C.autoRepairTagSuspended) tags
 221       futureTs = filter (> time) . map (flip TOD 0) $
 222                    mapMaybe (tryRead "auto-repair suspend time") suspended
 223   in
 224    case () of
 225      -- Note how we must return ArSuspended even if "enabled" is empty, so that
 226      -- node groups or instances can suspend repairs that were enabled at an
 227      -- upper scope (cluster or node group).
 228      _ | "" `elem` suspended -> Just $ ArSuspended Forever
 229        | not $ null futureTs -> Just . ArSuspended . Until . maximum $ futureTs
 230        | not $ null enabled  -> Just $ ArEnabled (minimum enabled)
 231        | otherwise           -> Nothing
 232
 233 -- | Compute the longest common suffix of a list of strings that
 234 -- starts with a dot.
 235 longestDomain :: [String] -> String
 236 longestDomain [] = ""
 237 longestDomain (x:xs) =
 238   foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
 239                             then suffix
 240                             else accu)
 241           "" $ filter (isPrefixOf ".") (tails x)
 242
 243 -- | Extracts the exclusion tags from the cluster configuration.
 244 extractExTags :: [String] -> [String]
 245 extractExTags = filter (not . null) . mapMaybe (chompPrefix exTagsPrefix)
 246
 247 -- | Extracts the common suffix from node\/instance names.
 248 commonSuffix :: Node.List -> Instance.List -> String
 249 commonSuffix nl il =
 250   let node_names = map Node.name $ Container.elems nl
 251       inst_names = map Instance.name $ Container.elems il
 252   in longestDomain (node_names ++ inst_names)
 253
 254 -- | Initializer function that loads the data from a node and instance
 255 -- list and massages it into the correct format.
 256 mergeData :: [(String, DynUtil)]  -- ^ Instance utilisation data
 257           -> [String]             -- ^ Exclusion tags
 258           -> [String]             -- ^ Selected instances (if not empty)
 259           -> [String]             -- ^ Excluded instances
 260           -> ClockTime            -- ^ The current timestamp
 261           -> ClusterData          -- ^ Data from backends
 262           -> Result ClusterData   -- ^ Fixed cluster data
 263 mergeData um extags selinsts exinsts time cdata@(ClusterData gl nl il ctags _) =
 264   let il2 = setArPolicy ctags gl nl il time
 265       il3 = foldl' (\im (name, n_util) ->
 266                         case Container.findByName im name of
 267                           Nothing -> im -- skipping unknown instance
 268                           Just inst ->
 269                               let new_i = inst { Instance.util = n_util }
 270                               in Container.add (Instance.idx inst) new_i im
 271                    ) il2 um
 272       allextags = extags ++ extractExTags ctags
 273       inst_names = map Instance.name $ Container.elems il3
 274       selinst_lkp = map (lookupName inst_names) selinsts
 275       exinst_lkp = map (lookupName inst_names) exinsts
 276       lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
 277       selinst_names = map lrContent selinst_lkp
 278       exinst_names = map lrContent exinst_lkp
 279       node_names = map Node.name (Container.elems nl)
 280       common_suffix = longestDomain (node_names ++ inst_names)
 281       il4 = Container.map (computeAlias common_suffix .
 282                            updateExclTags allextags .
 283                            updateMovable selinst_names exinst_names) il3
 284       nl2 = foldl' fixNodes nl (Container.elems il4)
 285       nl3 = Container.map (setNodePolicy gl .
 286                            computeAlias common_suffix .
 287                            (`Node.buildPeers` il4)) nl2
 288       il5 = Container.map (disableSplitMoves nl3) il4
 289   in if' (null lkp_unknown)
 290          (Ok cdata { cdNodes = nl3, cdInstances = il5 })
 291          (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))
 292
 293 -- | In a cluster description, clear dynamic utilisation information.
 294 clearDynU :: ClusterData -> Result ClusterData
 295 clearDynU cdata@(ClusterData _ _ il _ _) =
 296   let il2 = Container.map (\ inst -> inst {Instance.util = zeroUtil }) il
 297   in Ok cdata { cdInstances = il2 }
 298
 299 -- | Checks the cluster data for consistency.
 300 checkData :: Node.List -> Instance.List
 301           -> ([String], Node.List)
 302 checkData nl il =
 303     Container.mapAccum
 304         (\ msgs node ->
 305              let nname = Node.name node
 306                  nilst = map (`Container.find` il) (Node.pList node)
 307                  dilst = filter Instance.instanceDown nilst
 308                  adj_mem = sum . map Instance.mem $ dilst
 309                  delta_mem = truncate (Node.tMem node)
 310                              - Node.nMem node
 311                              - Node.fMem node
 312                              - nodeImem node il
 313                              + adj_mem
 314                  delta_dsk = truncate (Node.tDsk node)
 315                              - Node.fDsk node
 316                              - nodeIdsk node il
 317                  newn = Node.setFmem (Node.setXmem node delta_mem)
 318                         (Node.fMem node - adj_mem)
 319                  umsg1 =
 320                    if delta_mem > 512 || delta_dsk > 1024
 321                       then printf "node %s is missing %d MB ram \
 322                                   \and %d GB disk"
 323                                   nname delta_mem (delta_dsk `div` 1024):msgs
 324                       else msgs
 325              in (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       il' = map rfind $ Node.pList node
 333       oil' = filter Instance.notOffline il'
 334   in sum . map Instance.mem $ oil'
 335
 336
 337 -- | Compute the amount of disk used by instances on a node (either primary
 338 -- or secondary).
 339 nodeIdsk :: Node.Node -> Instance.List -> Int
 340 nodeIdsk node il =
 341   let rfind = flip Container.find il
 342   in sum . map (Instance.dsk . rfind)
 343        $ Node.pList node ++ Node.sList node
 344
 345 -- | Get live information or a default value
 346 eitherLive :: (Monad m) => Bool -> a -> m a -> m a
 347 eitherLive True _ live_data = live_data
 348 eitherLive False def_data _ = return def_data