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