Loader.hs: ignore expired ArSuspended policies

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

@@ -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
 

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)
 

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

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

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

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 _ _) ->