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