Make Query operators enforce strictness

[ganeti-local] / htools / Ganeti / HTools / Loader.hs

diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs
index 89b479d..95cad79 100644 (file)
--- a/htools/Ganeti/HTools/Loader.hs
+++ b/htools/Ganeti/HTools/Loader.hs
@@ -7,7 +7,7 @@ has been loaded from external sources.
 
 {-
 
 
 {-
 

-Copyright (C) 2009, 2010, 2011 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012 Google Inc.

 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by

@@ -27,19 +27,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 -}
 
 module Ganeti.HTools.Loader
 -}
 
 module Ganeti.HTools.Loader

-    ( mergeData
-    , checkData
-    , assignIndices
-    , lookupNode
-    , lookupInstance
-    , lookupGroup
-    , commonSuffix
-    , RelocMode(..)
-    , RqType(..)
-    , Request(..)
-    , ClusterData(..)
-    , emptyCluster
-    ) where
+  ( mergeData
+  , checkData
+  , assignIndices
+  , lookupNode
+  , lookupInstance
+  , lookupGroup
+  , commonSuffix
+  , RqType(..)
+  , Request(..)
+  , ClusterData(..)
+  , emptyCluster
+  ) where

 
 import Data.List
 import qualified Data.Map as M
 
 import Data.List
 import qualified Data.Map as M

@@ -49,8 +48,11 @@ import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group

+import qualified Ganeti.HTools.Cluster as Cluster

 
 

+import Ganeti.BasicTypes

 import Ganeti.HTools.Types
 import Ganeti.HTools.Types

+import Ganeti.Utils

 
 -- * Constants
 
 
 -- * Constants
 

@@ -60,12 +62,6 @@ exTagsPrefix = "htools:iextags:"
 
 -- * Types
 
 
 -- * Types
 

--- | The iallocator multi-evac group mode type.
-data RelocMode = KeepGroup
-               | ChangeGroup [Gdx]
-               | AnyGroup
-                 deriving (Show, Read)
-

 {-| The iallocator request type.
 
 This type denotes what request we got from Ganeti and also holds
 {-| The iallocator request type.
 
 This type denotes what request we got from Ganeti and also holds

@@ -73,51 +69,49 @@ request-specific fields.
 
 -}
 data RqType
 
 -}
 data RqType

-    = Allocate Instance.Instance Int -- ^ A new instance allocation
-    | Relocate Idx Int [Ndx]         -- ^ Move an instance to a new
-                                     -- secondary node
-    | Evacuate [Ndx]                 -- ^ Evacuate nodes
-    | MultiReloc [Idx] RelocMode     -- ^ Multi-relocate mode
-    deriving (Show, Read)
+  = Allocate Instance.Instance Int           -- ^ A new instance allocation
+  | Relocate Idx Int [Ndx]                   -- ^ Choose a new secondary node
+  | NodeEvacuate [Idx] EvacMode              -- ^ node-evacuate mode
+  | ChangeGroup [Gdx] [Idx]                  -- ^ Multi-relocate mode
+  | MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode
+    deriving (Show)

 
 -- | A complete request, as received from Ganeti.
 data Request = Request RqType ClusterData
 
 -- | A complete request, as received from Ganeti.
 data Request = Request RqType ClusterData

-    deriving (Show, Read)
+               deriving (Show)

 
 -- | The cluster state.
 data ClusterData = ClusterData
 
 -- | The cluster state.
 data ClusterData = ClusterData

-    { cdGroups    :: Group.List    -- ^ The node group list
-    , cdNodes     :: Node.List     -- ^ The node list
-    , cdInstances :: Instance.List -- ^ The instance list
-    , cdTags      :: [String]      -- ^ The cluster tags
-    } deriving (Show, Read)
+  { cdGroups    :: Group.List    -- ^ The node group list
+  , cdNodes     :: Node.List     -- ^ The node list
+  , cdInstances :: Instance.List -- ^ The instance list
+  , cdTags      :: [String]      -- ^ The cluster tags
+  , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy
+  } deriving (Show, Eq)

 
 -- | An empty cluster.
 emptyCluster :: ClusterData
 emptyCluster = ClusterData Container.empty Container.empty Container.empty []
 
 -- | An empty cluster.
 emptyCluster :: ClusterData
 emptyCluster = ClusterData Container.empty Container.empty Container.empty []

+                 defIPolicy

 
 -- * Functions
 
 -- | Lookups a node into an assoc list.
 lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
 lookupNode ktn inst node =
 
 -- * Functions
 
 -- | Lookups a node into an assoc list.
 lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
 lookupNode ktn inst node =

-    case M.lookup node ktn of
-      Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
-      Just idx -> return idx
+  maybe (fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst) return $
+    M.lookup node ktn

 
 -- | Lookups an instance into an assoc list.
 lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
 lookupInstance kti inst =
 
 -- | Lookups an instance into an assoc list.
 lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
 lookupInstance kti inst =

-    case M.lookup inst kti of
-      Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
-      Just idx -> return idx
+  maybe (fail $ "Unknown instance '" ++ inst ++ "'") return $ M.lookup inst kti

 
 -- | Lookups a group into an assoc list.
 lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
 lookupGroup ktg nname gname =
 
 -- | Lookups a group into an assoc list.
 lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
 lookupGroup ktg nname gname =

-    case M.lookup gname ktg of
-      Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
-      Just idx -> return idx
+  maybe (fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname) return $
+    M.lookup gname ktg

 
 -- | Given a list of elements (and their names), assign indices to them.
 assignIndices :: (Element a) =>
 
 -- | Given a list of elements (and their names), assign indices to them.
 assignIndices :: (Element a) =>

@@ -134,26 +128,32 @@ fixNodes :: Node.List
          -> Instance.Instance
          -> Node.List
 fixNodes accu inst =
          -> Instance.Instance
          -> Node.List
 fixNodes accu inst =

-    let
-        pdx = Instance.pNode inst
-        sdx = Instance.sNode inst
-        pold = Container.find pdx accu
-        pnew = Node.setPri pold inst
-        ac2 = Container.add pdx pnew accu
-    in
-      if sdx /= Node.noSecondary
-      then let sold = Container.find sdx accu
-               snew = Node.setSec sold inst
-           in Container.add sdx snew ac2
-      else ac2
-
--- | Remove non-selected tags from the exclusion list.
-filterExTags :: [String] -> Instance.Instance -> Instance.Instance
-filterExTags tl inst =
-    let old_tags = Instance.tags inst
-        new_tags = filter (\tag -> any (`isPrefixOf` tag) tl)
-                   old_tags
-    in inst { Instance.tags = new_tags }
+  let pdx = Instance.pNode inst
+      sdx = Instance.sNode inst
+      pold = Container.find pdx accu
+      pnew = Node.setPri pold inst
+      ac2 = Container.add pdx pnew accu
+  in if sdx /= Node.noSecondary
+       then let sold = Container.find sdx accu
+                snew = Node.setSec sold inst
+            in Container.add sdx snew ac2
+       else ac2
+
+-- | Set the node's policy to its group one. Note that this requires
+-- the group to exist (should have been checked before), otherwise it
+-- will abort with a runtime error.
+setNodePolicy :: Group.List -> Node.Node -> Node.Node
+setNodePolicy gl node =
+  let grp = Container.find (Node.group node) gl
+      gpol = Group.iPolicy grp
+  in Node.setPolicy gpol node
+
+-- | Update instance with exclusion tags list.
+updateExclTags :: [String] -> Instance.Instance -> Instance.Instance
+updateExclTags tl inst =
+  let allTags = Instance.allTags inst
+      exclTags = filter (\tag -> any (`isPrefixOf` tag) tl) allTags
+  in inst { Instance.exclTags = exclTags }

 
 -- | Update the movable attribute.
 updateMovable :: [String]           -- ^ Selected instances (if not empty)
 
 -- | Update the movable attribute.
 updateMovable :: [String]           -- ^ Selected instances (if not empty)

@@ -161,9 +161,15 @@ updateMovable :: [String]           -- ^ Selected instances (if not empty)
               -> Instance.Instance  -- ^ Target Instance
               -> Instance.Instance  -- ^ Target Instance with updated attribute
 updateMovable selinsts exinsts inst =
               -> Instance.Instance  -- ^ Target Instance
               -> Instance.Instance  -- ^ Target Instance with updated attribute
 updateMovable selinsts exinsts inst =

-    if Instance.sNode inst == Node.noSecondary ||
-       Instance.name inst `elem` exinsts ||
-       not (null selinsts || Instance.name inst `elem` selinsts)
+  if Instance.name inst `elem` exinsts ||
+     not (null selinsts || Instance.name inst `elem` selinsts)
+    then Instance.setMovable inst False
+    else inst
+
+-- | Disables moves for instances with a split group.
+disableSplitMoves :: Node.List -> Instance.Instance -> Instance.Instance
+disableSplitMoves nl inst =
+  if not . isOk . Cluster.instanceGroup nl $ inst

     then Instance.setMovable inst False
     else inst
 
     then Instance.setMovable inst False
     else inst
 

@@ -172,23 +178,23 @@ updateMovable selinsts exinsts inst =
 longestDomain :: [String] -> String
 longestDomain [] = ""
 longestDomain (x:xs) =
 longestDomain :: [String] -> String
 longestDomain [] = ""
 longestDomain (x:xs) =

-      foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
-                              then suffix
-                              else accu)
-      "" $ filter (isPrefixOf ".") (tails x)
+  foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
+                            then suffix
+                            else accu)
+          "" $ filter (isPrefixOf ".") (tails x)

 
 -- | Extracts the exclusion tags from the cluster configuration.
 extractExTags :: [String] -> [String]
 extractExTags =
 
 -- | Extracts the exclusion tags from the cluster configuration.
 extractExTags :: [String] -> [String]
 extractExTags =

-    map (drop (length exTagsPrefix)) .
-    filter (isPrefixOf exTagsPrefix)
+  map (drop (length exTagsPrefix)) .
+  filter (isPrefixOf exTagsPrefix)

 
 -- | Extracts the common suffix from node\/instance names.
 commonSuffix :: Node.List -> Instance.List -> String
 commonSuffix nl il =
 
 -- | Extracts the common suffix from node\/instance names.
 commonSuffix :: Node.List -> Instance.List -> String
 commonSuffix nl il =

-    let node_names = map Node.name $ Container.elems nl
-        inst_names = map Instance.name $ Container.elems il
-    in longestDomain (node_names ++ inst_names)
+  let node_names = map Node.name $ Container.elems nl
+      inst_names = map Instance.name $ Container.elems il
+  in longestDomain (node_names ++ inst_names)

 
 -- | Initializer function that loads the data from a node and instance
 -- list and massages it into the correct format.
 
 -- | Initializer function that loads the data from a node and instance
 -- list and massages it into the correct format.

@@ -198,7 +204,7 @@ mergeData :: [(String, DynUtil)]  -- ^ Instance utilisation data
           -> [String]             -- ^ Excluded instances
           -> ClusterData          -- ^ Data from backends
           -> Result ClusterData   -- ^ Fixed cluster data
           -> [String]             -- ^ Excluded instances
           -> ClusterData          -- ^ Data from backends
           -> Result ClusterData   -- ^ Fixed cluster data

-mergeData um extags selinsts exinsts cdata@(ClusterData _ nl il2 tags) =
+mergeData um extags selinsts exinsts cdata@(ClusterData gl nl il2 tags _) =

   let il = Container.elems il2
       il3 = foldl' (\im (name, n_util) ->
                         case Container.findByName im name of
   let il = Container.elems il2
       il3 = foldl' (\im (name, n_util) ->
                         case Container.findByName im name of

@@ -208,23 +214,25 @@ mergeData um extags selinsts exinsts cdata@(ClusterData _ nl il2 tags) =
                               in Container.add (Instance.idx inst) new_i im
                    ) il2 um
       allextags = extags ++ extractExTags tags
                               in Container.add (Instance.idx inst) new_i im
                    ) il2 um
       allextags = extags ++ extractExTags tags

-      il4 = Container.map (filterExTags allextags .
-                           updateMovable selinsts exinsts) il3
-      nl2 = foldl' fixNodes nl (Container.elems il4)
-      nl3 = Container.map (flip Node.buildPeers il4) nl2
-      node_names = map Node.name (Container.elems nl)

       inst_names = map Instance.name il
       inst_names = map Instance.name il

+      selinst_lkp = map (lookupName inst_names) selinsts
+      exinst_lkp = map (lookupName inst_names) exinsts
+      lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
+      selinst_names = map lrContent selinst_lkp
+      exinst_names = map lrContent exinst_lkp
+      node_names = map Node.name (Container.elems nl)

       common_suffix = longestDomain (node_names ++ inst_names)
       common_suffix = longestDomain (node_names ++ inst_names)

-      snl = Container.map (computeAlias common_suffix) nl3
-      sil = Container.map (computeAlias common_suffix) il4
-      all_inst_names = concatMap allNames $ Container.elems sil
-  in if not $ all (`elem` all_inst_names) exinsts
-     then Bad $ "Some of the excluded instances are unknown: " ++
-          show (exinsts \\ all_inst_names)
-     else if not $ all (`elem` all_inst_names) selinsts
-          then Bad $ "Some of the selected instances are unknown: " ++
-               show (selinsts \\ all_inst_names)
-          else Ok cdata { cdNodes = snl, cdInstances = sil }
+      il4 = Container.map (computeAlias common_suffix .
+                           updateExclTags allextags .
+                           updateMovable selinst_names exinst_names) il3
+      nl2 = foldl' fixNodes nl (Container.elems il4)
+      nl3 = Container.map (setNodePolicy gl .
+                           computeAlias common_suffix .
+                           (`Node.buildPeers` il4)) nl2
+      il5 = Container.map (disableSplitMoves nl3) il4
+  in if' (null lkp_unknown)
+         (Ok cdata { cdNodes = nl3, cdInstances = il5 })
+         (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))

 
 -- | Checks the cluster data for consistency.
 checkData :: Node.List -> Instance.List
 
 -- | Checks the cluster data for consistency.
 checkData :: Node.List -> Instance.List

@@ -234,7 +242,7 @@ checkData nl il =
         (\ msgs node ->
              let nname = Node.name node
                  nilst = map (`Container.find` il) (Node.pList node)
         (\ msgs node ->
              let nname = Node.name node
                  nilst = map (`Container.find` il) (Node.pList node)

-                 dilst = filter (not . Instance.running) nilst
+                 dilst = filter Instance.instanceDown nilst

                  adj_mem = sum . map Instance.mem $ dilst
                  delta_mem = truncate (Node.tMem node)
                              - Node.nMem node
                  adj_mem = sum . map Instance.mem $ dilst
                  delta_mem = truncate (Node.tMem node)
                              - Node.nMem node

@@ -246,24 +254,28 @@ checkData nl il =
                              - nodeIdsk node il
                  newn = Node.setFmem (Node.setXmem node delta_mem)
                         (Node.fMem node - adj_mem)
                              - nodeIdsk node il
                  newn = Node.setFmem (Node.setXmem node delta_mem)
                         (Node.fMem node - adj_mem)

-                 umsg1 = [printf "node %s is missing %d MB ram \
-                                 \and %d GB disk"
-                                 nname delta_mem (delta_dsk `div` 1024) |
-                                 delta_mem > 512 || delta_dsk > 1024]::[String]
-             in (msgs ++ umsg1, newn)
+                 umsg1 =
+                   if delta_mem > 512 || delta_dsk > 1024
+                      then printf "node %s is missing %d MB ram \
+                                  \and %d GB disk"
+                                  nname delta_mem (delta_dsk `div` 1024):msgs
+                      else msgs
+             in (umsg1, newn)

         ) [] nl
 
 -- | Compute the amount of memory used by primary instances on a node.
 nodeImem :: Node.Node -> Instance.List -> Int
 nodeImem node il =
         ) [] nl
 
 -- | Compute the amount of memory used by primary instances on a node.
 nodeImem :: Node.Node -> Instance.List -> Int
 nodeImem node il =

-    let rfind = flip Container.find il
-    in sum . map (Instance.mem . rfind)
-           $ Node.pList node
+  let rfind = flip Container.find il
+      il' = map rfind $ Node.pList node
+      oil' = filter Instance.notOffline il'
+  in sum . map Instance.mem $ oil'
+

 
 -- | Compute the amount of disk used by instances on a node (either primary
 -- or secondary).
 nodeIdsk :: Node.Node -> Instance.List -> Int
 nodeIdsk node il =
 
 -- | Compute the amount of disk used by instances on a node (either primary
 -- or secondary).
 nodeIdsk :: Node.Node -> Instance.List -> Int
 nodeIdsk node il =

-    let rfind = flip Container.find il
-    in sum . map (Instance.dsk . rfind)
-           $ Node.pList node ++ Node.sList node
+  let rfind = flip Container.find il
+  in sum . map (Instance.dsk . rfind)
+       $ Node.pList node ++ Node.sList node