Improve TemplateHaskell code to support empty objects

[ganeti-local] / src / Ganeti / Jobs.hs

diff --git a/src/Ganeti/Jobs.hs b/src/Ganeti/Jobs.hs
index 5af10a5..179a3a0 100644 (file)
--- a/src/Ganeti/Jobs.hs
+++ b/src/Ganeti/Jobs.hs
@@ -26,10 +26,12 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 module Ganeti.Jobs
   ( submitJobs
   , execJobsWait
 module Ganeti.Jobs
   ( submitJobs
   , execJobsWait

+  , execJobsWaitOk

   , waitForJobs
   ) where
 
 import Control.Concurrent (threadDelay)
   , waitForJobs
   ) where
 
 import Control.Concurrent (threadDelay)

+import Data.List

 
 import Ganeti.BasicTypes
 import Ganeti.Errors
 
 import Ganeti.BasicTypes
 import Ganeti.Errors

@@ -60,16 +62,34 @@ execJobsWait opcodes callback client = do
       callback jids'
       waitForJobs jids' client
 
       callback jids'
       waitForJobs jids' client
 

--- | Polls a set of jobs at a fixed interval until all are finished
--- one way or another.
+-- | Polls a set of jobs at an increasing interval until all are finished one
+-- way or another.

 waitForJobs :: [L.JobId] -> L.Client -> IO (Result [(L.JobId, JobStatus)])
 waitForJobs :: [L.JobId] -> L.Client -> IO (Result [(L.JobId, JobStatus)])

-waitForJobs jids client = do
-  sts <- L.queryJobsStatus client jids
+waitForJobs jids client = waitForJobs' 500000 15000000
+  where
+    waitForJobs' delay maxdelay = do
+      -- TODO: this should use WaitForJobChange once it's available in Haskell
+      -- land, instead of a fixed schedule of sleeping intervals.
+      threadDelay $ min delay maxdelay
+      sts <- L.queryJobsStatus client jids
+      case sts of
+        Bad e -> return . Bad $ "Checking job status: " ++ formatError e
+        Ok sts' -> if any (<= JOB_STATUS_RUNNING) sts' then
+                     waitForJobs' (delay * 2) maxdelay
+                   else
+                     return . Ok $ zip jids sts'
+
+-- | Execute jobs and return @Ok@ only if all of them succeeded.
+execJobsWaitOk :: [[MetaOpCode]] -> L.Client -> IO (Result ())
+execJobsWaitOk opcodes client = do
+  let nullog = const (return () :: IO ())
+      failed = filter ((/=) JOB_STATUS_SUCCESS . snd)
+      fmtfail (i, s) = show (fromJobId i) ++ "=>" ++ jobStatusToRaw s
+  sts <- execJobsWait opcodes nullog client

   case sts of
   case sts of

-    Bad e -> return . Bad $ "Checking job status: " ++ formatError e
-    Ok sts' -> if any (<= JOB_STATUS_RUNNING) sts'
-            then do
-              -- TODO: replace hardcoded value with a better thing
-              threadDelay (1000000 * 15)
-              waitForJobs jids client
-            else return . Ok $ zip jids sts'
+    Bad e -> return $ Bad e
+    Ok sts' -> return (if null $ failed sts' then
+                         Ok ()
+                       else
+                         Bad ("The following jobs failed: " ++
+                              (intercalate ", " . map fmtfail $ failed sts')))