From ef947a429d753b08a0604524fcb47672e4da66ba Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dato=20Sim=C3=B3?= <dato@google.com>
Date: Wed, 9 Jan 2013 18:12:14 +0000
Subject: [PATCH] Loader.hs: ignore expired ArSuspended policies
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
At the moment, because 'mergeData' is pure, it may set instance auto-repair
policies that are of the form `ArSuspended $ Until timestamp_in_the_past`.
If later on the auto-repair tool notices this, it has lost access to what
would be the next-in-line policy to use (and would have to re-parse all
tags again).
To avoid this, we pass the current time to 'mergeData' from ExtLoader.hs,
and we propagate it to Loader.getArPolicy. ExtLoader.loadExternalData is in
the IO monad, so it has ready access to getClockTime.
A few other places were calling 'mergeData' directly. For Hscan.hs and
IAlloc.hs, we add appropriate calls to getClockTime. For files under test/,
we use a current time of 0.
Signed-off-by: Dato SimΓ³ <dato@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>
---
src/Ganeti/HTools/Backend/IAlloc.hs | 11 +++++---
src/Ganeti/HTools/ExtLoader.hs | 4 ++-
src/Ganeti/HTools/Loader.hs | 32 ++++++++++++----------
src/Ganeti/HTools/Program/Hscan.hs | 10 ++++---
test/hs/Test/Ganeti/HTools/Backend/Text.hs | 4 ++-
test/hs/Test/Ganeti/HTools/Loader.hs | 3 +-
6 files changed, 38 insertions(+), 26 deletions(-)
diff --git a/src/Ganeti/HTools/Backend/IAlloc.hs b/src/Ganeti/HTools/Backend/IAlloc.hs
index fe0746fc6..6c3fdf161 100644
--- a/src/Ganeti/HTools/Backend/IAlloc.hs
+++ b/src/Ganeti/HTools/Backend/IAlloc.hs
@@ -34,6 +34,7 @@ import Data.Either ()
import Data.Maybe (fromMaybe, isJust, fromJust)
import Data.List
import Control.Monad
+import System.Time
import Text.JSON (JSObject, JSValue(JSArray),
makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
@@ -138,9 +139,10 @@ parseGroup u a = do
-- The result is a tuple of eventual warning messages and the parsed
-- request; if parsing the input data fails, we'll return a 'Bad'
-- value.
-parseData :: String -- ^ The JSON message as received from Ganeti
+parseData :: ClockTime -- ^ The current time
+ -> String -- ^ The JSON message as received from Ganeti
-> Result ([String], Request) -- ^ Result tuple
-parseData body = do
+parseData now body = do
decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
let obj = fromJSObject decoded
extrObj x = tryFromObj "invalid iallocator message" obj x
@@ -165,7 +167,7 @@ parseData body = do
let (kti, il) = assignIndices iobj
-- cluster tags
ctags <- extrObj "cluster_tags"
- cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags defIPolicy)
+ cdata1 <- mergeData [] [] [] [] now (ClusterData gl nl il ctags defIPolicy)
let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
cdata = cdata1 { cdNodes = fix_nl }
map_n = cdNodes cdata
@@ -380,10 +382,11 @@ processRequest request =
-- | Reads the request from the data file(s).
readRequest :: FilePath -> IO Request
readRequest fp = do
+ now <- getClockTime
input_data <- case fp of
"-" -> getContents
_ -> readFile fp
- case parseData input_data of
+ case parseData now input_data of
Bad err -> exitErr err
Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
diff --git a/src/Ganeti/HTools/ExtLoader.hs b/src/Ganeti/HTools/ExtLoader.hs
index 89b147843..a6b19a25b 100644
--- a/src/Ganeti/HTools/ExtLoader.hs
+++ b/src/Ganeti/HTools/ExtLoader.hs
@@ -38,6 +38,7 @@ import Control.Exception
import Data.Maybe (isJust, fromJust)
import System.FilePath
import System.IO
+import System.Time (getClockTime)
import Text.Printf (hPrintf)
import qualified Ganeti.HTools.Backend.Luxi as Luxi
@@ -107,8 +108,9 @@ loadExternalData opts = do
| setFile -> wrapIO . Text.loadData $ fromJust tfile
| setIAllocSrc -> wrapIO . IAlloc.loadData $ fromJust iallocsrc
| otherwise -> return $ Bad "No backend selected! Exiting."
+ now <- getClockTime
- let ldresult = input_data >>= mergeData util_data exTags selInsts exInsts
+ let ldresult = input_data >>= mergeData util_data exTags selInsts exInsts now
cdata <- exitIfBad "failed to load data, aborting" ldresult
let (fix_msgs, nl) = checkData (cdNodes cdata) (cdInstances cdata)
diff --git a/src/Ganeti/HTools/Loader.hs b/src/Ganeti/HTools/Loader.hs
index ab41f0364..f5b5c723d 100644
--- a/src/Ganeti/HTools/Loader.hs
+++ b/src/Ganeti/HTools/Loader.hs
@@ -182,11 +182,13 @@ setArPolicy :: [String] -- ^ Cluster tags
-> Group.List -- ^ List of node groups
-> Node.List -- ^ List of nodes
-> Instance.List -- ^ List of instances
+ -> ClockTime -- ^ Current timestamp, to evaluate ArSuspended
-> Instance.List -- ^ Updated list of instances
-setArPolicy ctags gl nl il =
- let cpol = fromMaybe ArNotEnabled $ getArPolicy ctags
- gpols = Container.map (fromMaybe cpol . getArPolicy . Group.allTags) gl
- ipolfn = getArPolicy . Instance.allTags
+setArPolicy ctags gl nl il time =
+ let getArPolicy' = flip getArPolicy time
+ cpol = fromMaybe ArNotEnabled $ getArPolicy' ctags
+ gpols = Container.map (fromMaybe cpol . getArPolicy' . Group.allTags) gl
+ ipolfn = getArPolicy' . Instance.allTags
nlookup = flip Container.find nl . Instance.pNode
glookup = flip Container.find gpols . Node.group . nlookup
updateInstance inst = inst {
@@ -199,23 +201,22 @@ setArPolicy ctags gl nl il =
-- This examines the ganeti:watcher:autorepair and
-- ganeti:watcher:autorepair:suspend tags to determine the policy. If none of
-- these tags are present, Nothing (and not ArNotEnabled) is returned.
-getArPolicy :: [String] -> Maybe AutoRepairPolicy
-getArPolicy tags =
+getArPolicy :: [String] -> ClockTime -> Maybe AutoRepairPolicy
+getArPolicy tags time =
let enabled = mapMaybe (autoRepairTypeFromRaw <=<
chompPrefix C.autoRepairTagEnabled) tags
suspended = mapMaybe (chompPrefix C.autoRepairTagSuspended) tags
- suspTime = if "" `elem` suspended
- then Forever
- else Until . flip TOD 0 . maximum $
- mapMaybe (tryRead "auto-repair suspend time") suspended
+ futureTs = filter (> time) . map (flip TOD 0) $
+ mapMaybe (tryRead "auto-repair suspend time") suspended
in
case () of
-- Note how we must return ArSuspended even if "enabled" is empty, so that
-- node groups or instances can suspend repairs that were enabled at an
-- upper scope (cluster or node group).
- _ | not $ null suspended -> Just $ ArSuspended suspTime
- | not $ null enabled -> Just $ ArEnabled (minimum enabled)
- | otherwise -> Nothing
+ _ | "" `elem` suspended -> Just $ ArSuspended Forever
+ | not $ null futureTs -> Just . ArSuspended . Until . maximum $ futureTs
+ | not $ null enabled -> Just $ ArEnabled (minimum enabled)
+ | otherwise -> Nothing
-- | Compute the longest common suffix of a list of strings that
-- starts with a dot.
@@ -244,10 +245,11 @@ mergeData :: [(String, DynUtil)] -- ^ Instance utilisation data
-> [String] -- ^ Exclusion tags
-> [String] -- ^ Selected instances (if not empty)
-> [String] -- ^ Excluded instances
+ -> ClockTime -- ^ The current timestamp
-> ClusterData -- ^ Data from backends
-> Result ClusterData -- ^ Fixed cluster data
-mergeData um extags selinsts exinsts cdata@(ClusterData gl nl il ctags _) =
- let il2 = setArPolicy ctags gl nl il
+mergeData um extags selinsts exinsts time cdata@(ClusterData gl nl il ctags _) =
+ let il2 = setArPolicy ctags gl nl il time
il3 = foldl' (\im (name, n_util) ->
case Container.findByName im name of
Nothing -> im -- skipping unknown instance
diff --git a/src/Ganeti/HTools/Program/Hscan.hs b/src/Ganeti/HTools/Program/Hscan.hs
index 854b764d7..38829cdc2 100644
--- a/src/Ganeti/HTools/Program/Hscan.hs
+++ b/src/Ganeti/HTools/Program/Hscan.hs
@@ -34,6 +34,7 @@ import Data.Maybe (isJust, fromJust, fromMaybe)
import System.Exit
import System.IO
import System.FilePath
+import System.Time
import Text.Printf (printf)
@@ -89,9 +90,9 @@ fixSlash :: String -> String
fixSlash = map (\x -> if x == '/' then '_' else x)
-- | Generates serialized data from loader input.
-processData :: ClusterData -> Result ClusterData
-processData input_data = do
- cdata@(ClusterData _ nl il _ _) <- mergeData [] [] [] [] input_data
+processData :: ClockTime -> ClusterData -> Result ClusterData
+processData now input_data = do
+ cdata@(ClusterData _ nl il _ _) <- mergeData [] [] [] [] now input_data
let (_, fix_nl) = checkData nl il
return cdata { cdNodes = fix_nl }
@@ -106,7 +107,8 @@ writeData _ name _ (Bad err) =
return False
writeData nlen name opts (Ok cdata) = do
- let fixdata = processData cdata
+ now <- getClockTime
+ let fixdata = processData now cdata
case fixdata of
Bad err -> printf "\nError for %s: failed to process data. Details:\n%s\n"
name err >> return False
diff --git a/test/hs/Test/Ganeti/HTools/Backend/Text.hs b/test/hs/Test/Ganeti/HTools/Backend/Text.hs
index ce95ff795..5763fa0a6 100644
--- a/test/hs/Test/Ganeti/HTools/Backend/Text.hs
+++ b/test/hs/Test/Ganeti/HTools/Backend/Text.hs
@@ -33,6 +33,7 @@ import Test.QuickCheck
import qualified Data.Map as Map
import Data.List
import Data.Maybe
+import System.Time (ClockTime(..))
import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
@@ -191,7 +192,8 @@ prop_CreateSerialise =
let cdata = Loader.ClusterData defGroupList nl' il' ctags
Types.defIPolicy
saved = Text.serializeCluster cdata
- in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
+ in case Text.parseData saved >>= Loader.mergeData [] [] [] [] (TOD 0 0)
+ of
Bad msg -> failTest $ "Failed to load/merge: " ++ msg
Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
conjoin [ ctags ==? ctags2
diff --git a/test/hs/Test/Ganeti/HTools/Loader.hs b/test/hs/Test/Ganeti/HTools/Loader.hs
index e825f2bd4..673a443d0 100644
--- a/test/hs/Test/Ganeti/HTools/Loader.hs
+++ b/test/hs/Test/Ganeti/HTools/Loader.hs
@@ -33,6 +33,7 @@ import Test.QuickCheck
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.List
+import System.Time (ClockTime(..))
import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
@@ -71,7 +72,7 @@ prop_assignIndices =
prop_mergeData :: [Node.Node] -> Bool
prop_mergeData ns =
let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
- in case Loader.mergeData [] [] [] []
+ in case Loader.mergeData [] [] [] [] (TOD 0 0)
(Loader.emptyCluster {Loader.cdNodes = na}) of
BasicTypes.Bad _ -> False
BasicTypes.Ok (Loader.ClusterData _ nl il _ _) ->
--
GitLab