From aa79e62e75140c70e49a6ffaa7a3a959f4f880ac Mon Sep 17 00:00:00 2001 From: Iustin Pop Date: Mon, 10 Dec 2012 19:38:49 +0100 Subject: [PATCH] Add a read-only job queue module MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit This patch adds implementation for a read-only job queue module, together with "full" test (as full as can be in a lazy language…). One note about the behaviour of the job queue is the handling of opcodes that fail validation: the 'input' opcode actually is a meta-type, which can hold either a real opcode or a plain JSValue, so that we can still load jobs with invalid opcodes for querying. The only downside of this is that, as opposed to Python code, we can't show the correct summary for such an opcode - we try to parse the OP_ID but not the extended OP_DSC_FIELD-equivalent. Signed-off-by: Iustin Pop Reviewed-by: Helga Velroyen --- Makefile.am | 2 + htest/Test/Ganeti/JQueue.hs | 302 +++++++++++++++++++++++++++++++++++++++++++ htest/test.hs | 2 + htools/Ganeti/JQueue.hs | 282 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 588 insertions(+) create mode 100644 htest/Test/Ganeti/JQueue.hs create mode 100644 htools/Ganeti/JQueue.hs diff --git a/Makefile.am b/Makefile.am index 2f95d16..cd76ac7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -483,6 +483,7 @@ HS_LIB_SRCS = \ htools/Ganeti/HTools/Program/Hspace.hs \ htools/Ganeti/HTools/Types.hs \ htools/Ganeti/Hash.hs \ + htools/Ganeti/JQueue.hs \ htools/Ganeti/JSON.hs \ htools/Ganeti/Jobs.hs \ htools/Ganeti/Logging.hs \ @@ -530,6 +531,7 @@ HS_TEST_SRCS = \ htest/Test/Ganeti/HTools/Types.hs \ htest/Test/Ganeti/JSON.hs \ htest/Test/Ganeti/Jobs.hs \ + htest/Test/Ganeti/JQueue.hs \ htest/Test/Ganeti/Luxi.hs \ htest/Test/Ganeti/Network.hs \ htest/Test/Ganeti/Objects.hs \ diff --git a/htest/Test/Ganeti/JQueue.hs b/htest/Test/Ganeti/JQueue.hs new file mode 100644 index 0000000..29f525a --- /dev/null +++ b/htest/Test/Ganeti/JQueue.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| Unittests for the job queue functionality. + +-} + +{- + +Copyright (C) 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 +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. + +-} + +module Test.Ganeti.JQueue (testJQueue) where + +import Control.Applicative +import Control.Monad (when) +import Data.Char (isAscii) +import Data.List (nub, sort) +import System.Directory +import System.FilePath +import System.IO.Temp +import System.Posix.Files +import Test.HUnit +import Test.QuickCheck as QuickCheck +import Test.QuickCheck.Monadic +import Text.JSON + +import Test.Ganeti.TestCommon +import Test.Ganeti.TestHelper +import Test.Ganeti.Types () +import Test.Ganeti.OpCodes + +import Ganeti.BasicTypes +import qualified Ganeti.Constants as C +import Ganeti.JQueue +import Ganeti.OpCodes +import Ganeti.Path +import Ganeti.Types as Types + +{-# ANN module "HLint: ignore Use camelCase" #-} + +-- * Helpers + +-- | noTimestamp in Just form. +justNoTs :: Maybe Timestamp +justNoTs = Just noTimestamp + +-- | Generates a simple queued opcode. +genQueuedOpCode :: Gen QueuedOpCode +genQueuedOpCode = + QueuedOpCode <$> pure (ValidOpCode $ wrapOpCode OpClusterQuery) <*> + arbitrary <*> pure JSNull <*> pure [] <*> + choose (C.opPrioLowest, C.opPrioHighest) <*> + pure justNoTs <*> pure justNoTs <*> pure justNoTs + +-- | Generates an static, empty job. +emptyJob :: (Monad m) => m QueuedJob +emptyJob = do + jid0 <- makeJobId 0 + return $ QueuedJob jid0 [] justNoTs justNoTs justNoTs + +-- | Generates a job ID. +genJobId :: Gen JobId +genJobId = do + p <- arbitrary::Gen (Types.NonNegative Int) + makeJobId $ fromNonNegative p + +-- * Test cases + +-- | Tests default priority value. +case_JobPriorityDef :: Assertion +case_JobPriorityDef = do + ej <- emptyJob + assertEqual "for default priority" C.opPrioDefault $ calcJobPriority ej + +-- | Test arbitrary priorities. +prop_JobPriority :: Property +prop_JobPriority = + forAll (listOf1 (genQueuedOpCode `suchThat` + (not . opStatusFinalized . qoStatus))) $ \ops -> do + jid0 <- makeJobId 0 + let job = QueuedJob jid0 ops justNoTs justNoTs justNoTs + calcJobPriority job ==? minimum (map qoPriority ops) + +-- | Tests default job status. +case_JobStatusDef :: Assertion +case_JobStatusDef = do + ej <- emptyJob + assertEqual "for job status" JOB_STATUS_SUCCESS $ calcJobStatus ej + +-- | Test some job status properties. +prop_JobStatus :: Property +prop_JobStatus = + forAll genJobId $ \jid -> + forAll genQueuedOpCode $ \op -> + let job1 = QueuedJob jid [op] justNoTs justNoTs justNoTs + st1 = calcJobStatus job1 + op_succ = op { qoStatus = OP_STATUS_SUCCESS } + op_err = op { qoStatus = OP_STATUS_ERROR } + op_cnl = op { qoStatus = OP_STATUS_CANCELING } + op_cnd = op { qoStatus = OP_STATUS_CANCELED } + -- computes status for a job with an added opcode before + st_pre_op pop = calcJobStatus (job1 { qjOps = pop:qjOps job1 }) + -- computes status for a job with an added opcode after + st_post_op pop = calcJobStatus (job1 { qjOps = qjOps job1 ++ [pop] }) + in conjoin + [ printTestCase "pre-success doesn't change status" + (st_pre_op op_succ ==? st1) + , printTestCase "post-success doesn't change status" + (st_post_op op_succ ==? st1) + , printTestCase "pre-error is error" + (st_pre_op op_err ==? JOB_STATUS_ERROR) + , printTestCase "pre-canceling is canceling" + (st_pre_op op_cnl ==? JOB_STATUS_CANCELING) + , printTestCase "pre-canceled is canceled" + (st_pre_op op_cnd ==? JOB_STATUS_CANCELED) + ] + +-- | Tests job status equivalence with Python. Very similar to OpCodes test. +case_JobStatusPri_py_equiv :: Assertion +case_JobStatusPri_py_equiv = do + let num_jobs = 2000::Int + sample_jobs <- sample' (vectorOf num_jobs $ do + num_ops <- choose (1, 5) + ops <- vectorOf num_ops genQueuedOpCode + jid <- genJobId + return $ QueuedJob jid ops justNoTs justNoTs + justNoTs) + let jobs = head sample_jobs + serialized = encode jobs + -- check for non-ASCII fields, usually due to 'arbitrary :: String' + mapM_ (\job -> when (any (not . isAscii) (encode job)) . + assertFailure $ "Job has non-ASCII fields: " ++ show job + ) jobs + py_stdout <- + runPython "from ganeti import jqueue\n\ + \from ganeti import serializer\n\ + \import sys\n\ + \job_data = serializer.Load(sys.stdin.read())\n\ + \decoded = [jqueue._QueuedJob.Restore(None, o, False, False)\n\ + \ for o in job_data]\n\ + \encoded = [(job.CalcStatus(), job.CalcPriority())\n\ + \ for job in decoded]\n\ + \print serializer.Dump(encoded)" serialized + >>= checkPythonResult + let deserialised = decode py_stdout::Text.JSON.Result [(String, Int)] + decoded <- case deserialised of + Text.JSON.Ok jobs' -> return jobs' + Error msg -> + assertFailure ("Unable to decode jobs: " ++ msg) + -- this already raised an expection, but we need it + -- for proper types + >> fail "Unable to decode jobs" + assertEqual "Mismatch in number of returned jobs" + (length decoded) (length jobs) + mapM_ (\(py_sp, job) -> + let hs_sp = (jobStatusToRaw $ calcJobStatus job, + calcJobPriority job) + in assertEqual ("Different result after encoding/decoding for " ++ + show job) py_sp hs_sp + ) $ zip decoded jobs + +-- | Tests listing of Job ids. +prop_ListJobIDs :: Property +prop_ListJobIDs = monadicIO $ do + jobs <- pick $ resize 10 (listOf1 genJobId `suchThat` (\l -> l == nub l)) + (e, f, g) <- + run . withSystemTempDirectory "jqueue-test." $ \tempdir -> do + empty_dir <- getJobIDs [tempdir] + mapM_ (\jid -> writeFile (tempdir jobFileName jid) "") jobs + full_dir <- getJobIDs [tempdir] + invalid_dir <- getJobIDs [tempdir "no-such-dir"] + return (empty_dir, sortJobIDs full_dir, invalid_dir) + stop $ conjoin [ printTestCase "empty directory" $ e ==? [] + , printTestCase "directory with valid names" $ + f ==? sortJobIDs jobs + , printTestCase "invalid directory" $ g ==? [] + ] + +-- | Tests loading jobs from disk. +prop_LoadJobs :: Property +prop_LoadJobs = monadicIO $ do + ops <- pick $ resize 5 (listOf1 genQueuedOpCode) + jid <- pick genJobId + let job = QueuedJob jid ops justNoTs justNoTs justNoTs + job_s = encode job + -- check that jobs in the right directories are parsed correctly + (missing, current, archived, missing_current, broken) <- + run . withSystemTempDirectory "jqueue-test." $ \tempdir -> do + let load a = loadJobFromDisk tempdir a jid + live_path = liveJobFile tempdir jid + arch_path = archivedJobFile tempdir jid + createDirectory $ tempdir jobQueueArchiveSubDir + createDirectory $ dropFileName arch_path + -- missing job + missing <- load True + writeFile live_path job_s + -- this should exist + current <- load False + removeFile live_path + writeFile arch_path job_s + -- this should exist (archived) + archived <- load True + -- this should be missing + missing_current <- load False + removeFile arch_path + writeFile live_path "invalid job" + broken <- load True + return (missing, current, archived, missing_current, broken) + stop $ conjoin [ missing ==? noSuchJob + , current ==? Ganeti.BasicTypes.Ok (job, False) + , archived ==? Ganeti.BasicTypes.Ok (job, True) + , missing_current ==? noSuchJob + , printTestCase "broken job" (isBad broken) + ] + +-- | Tests computing job directories. Creates random directories, +-- files and stale symlinks in a directory, and checks that we return +-- \"the right thing\". +prop_DetermineDirs :: Property +prop_DetermineDirs = monadicIO $ do + count <- pick $ choose (2, 10) + nums <- pick $ genUniquesList count + (arbitrary::Gen (QuickCheck.Positive Int)) + let (valid, invalid) = splitAt (count `div` 2) $ + map (\(QuickCheck.Positive i) -> show i) nums + (tempdir, non_arch, with_arch, invalid_root) <- + run . withSystemTempDirectory "jqueue-test." $ \tempdir -> do + let arch_dir = tempdir jobQueueArchiveSubDir + createDirectory arch_dir + mapM_ (createDirectory . (arch_dir )) valid + mapM_ (\p -> writeFile (arch_dir p) "") invalid + mapM_ (\p -> createSymbolicLink "/dev/null/no/such/file" + (arch_dir p <.> "missing")) invalid + non_arch <- determineJobDirectories tempdir False + with_arch <- determineJobDirectories tempdir True + invalid_root <- determineJobDirectories (tempdir "no-such-subdir") True + return (tempdir, non_arch, with_arch, invalid_root) + let arch_dir = tempdir jobQueueArchiveSubDir + stop $ conjoin [ non_arch ==? [tempdir] + , sort with_arch ==? sort (tempdir:map (arch_dir ) valid) + , invalid_root ==? [tempdir "no-such-subdir"] + ] + +-- | Tests the JSON serialisation for 'InputOpCode'. +prop_InputOpCode :: MetaOpCode -> Int -> Property +prop_InputOpCode meta i = + conjoin [ readJSON (showJSON valid) ==? Text.JSON.Ok valid + , readJSON (showJSON invalid) ==? Text.JSON.Ok invalid + ] + where valid = ValidOpCode meta + invalid = InvalidOpCode (showJSON i) + +-- | Tests 'extractOpSummary'. +prop_extractOpSummary :: MetaOpCode -> Int -> Property +prop_extractOpSummary meta i = + conjoin [ printTestCase "valid opcode" $ + extractOpSummary (ValidOpCode meta) ==? summary + , printTestCase "invalid opcode, correct object" $ + extractOpSummary (InvalidOpCode jsobj) ==? summary + , printTestCase "invalid opcode, empty object" $ + extractOpSummary (InvalidOpCode emptyo) ==? invalid + , printTestCase "invalid opcode, object with invalid OP_ID" $ + extractOpSummary (InvalidOpCode invobj) ==? invalid + , printTestCase "invalid opcode, not jsobject" $ + extractOpSummary (InvalidOpCode jsinval) ==? invalid + ] + where summary = opSummary (metaOpCode meta) + jsobj = showJSON $ toJSObject [("OP_ID", + showJSON ("OP_" ++ summary))] + emptyo = showJSON $ toJSObject ([]::[(String, JSValue)]) + invobj = showJSON $ toJSObject [("OP_ID", showJSON False)] + jsinval = showJSON i + invalid = "INVALID_OP" + +testSuite "JQueue" + [ 'case_JobPriorityDef + , 'prop_JobPriority + , 'case_JobStatusDef + , 'prop_JobStatus + , 'case_JobStatusPri_py_equiv + , 'prop_ListJobIDs + , 'prop_LoadJobs + , 'prop_DetermineDirs + , 'prop_InputOpCode + , 'prop_extractOpSummary + ] diff --git a/htest/test.hs b/htest/test.hs index 3bb1294..d7848aa 100644 --- a/htest/test.hs +++ b/htest/test.hs @@ -53,6 +53,7 @@ import Test.Ganeti.HTools.PeerMap import Test.Ganeti.HTools.Types import Test.Ganeti.JSON import Test.Ganeti.Jobs +import Test.Ganeti.JQueue import Test.Ganeti.Luxi import Test.Ganeti.Network import Test.Ganeti.Objects @@ -103,6 +104,7 @@ allTests = , testHTools_Types , testJSON , testJobs + , testJQueue , testLuxi , testNetwork , testObjects diff --git a/htools/Ganeti/JQueue.hs b/htools/Ganeti/JQueue.hs new file mode 100644 index 0000000..39aa3fc --- /dev/null +++ b/htools/Ganeti/JQueue.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| Implementation of the job queue. + +-} + +{- + +Copyright (C) 2010, 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 +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. + +-} + +module Ganeti.JQueue + ( QueuedOpCode(..) + , QueuedJob(..) + , InputOpCode(..) + , Timestamp + , noTimestamp + , opStatusFinalized + , extractOpSummary + , calcJobStatus + , calcJobPriority + , jobFileName + , liveJobFile + , archivedJobFile + , determineJobDirectories + , getJobIDs + , sortJobIDs + , loadJobFromDisk + , noSuchJob + ) where + +import Control.Exception +import Control.Monad +import Data.List +import Data.Ord (comparing) +-- workaround what seems to be a bug in ghc 7.4's TH shadowing code +import Prelude hiding (log, id) +import System.Directory +import System.FilePath +import System.IO.Error (isDoesNotExistError) +import System.Posix.Files +import qualified Text.JSON +import Text.JSON.Types + +import Ganeti.BasicTypes +import qualified Ganeti.Constants as C +import Ganeti.JSON +import Ganeti.Logging +import Ganeti.OpCodes +import Ganeti.Path +import Ganeti.THH +import Ganeti.Types + +-- * Data types + +-- | The ganeti queue timestamp type +type Timestamp = (Int, Int) + +-- | Missing timestamp type. +noTimestamp :: Timestamp +noTimestamp = (-1, -1) + +-- | An input opcode. +data InputOpCode = ValidOpCode MetaOpCode -- ^ OpCode was parsed successfully + | InvalidOpCode JSValue -- ^ Invalid opcode + deriving (Show, Eq) + +-- | JSON instance for 'InputOpCode', trying to parse it and if +-- failing, keeping the original JSValue. +instance Text.JSON.JSON InputOpCode where + showJSON (ValidOpCode mo) = Text.JSON.showJSON mo + showJSON (InvalidOpCode inv) = inv + readJSON v = case Text.JSON.readJSON v of + Text.JSON.Error _ -> return $ InvalidOpCode v + Text.JSON.Ok mo -> return $ ValidOpCode mo + +-- | Invalid opcode summary. +invalidOp :: String +invalidOp = "INVALID_OP" + +-- | Tries to extract the opcode summary from an 'InputOpCode'. This +-- duplicates some functionality from the 'opSummary' function in +-- "Ganeti.OpCodes". +extractOpSummary :: InputOpCode -> String +extractOpSummary (ValidOpCode metaop) = opSummary $ metaOpCode metaop +extractOpSummary (InvalidOpCode (JSObject o)) = + case fromObjWithDefault (fromJSObject o) "OP_ID" ("OP_" ++ invalidOp) of + Just s -> drop 3 s -- drop the OP_ prefix + Nothing -> invalidOp +extractOpSummary _ = invalidOp + +$(buildObject "QueuedOpCode" "qo" + [ simpleField "input" [t| InputOpCode |] + , simpleField "status" [t| OpStatus |] + , simpleField "result" [t| JSValue |] + , defaultField [| [] |] $ + simpleField "log" [t| [(Int, Timestamp, ELogType, JSValue)] |] + , simpleField "priority" [t| Int |] + , optionalNullSerField $ + simpleField "start_timestamp" [t| Timestamp |] + , optionalNullSerField $ + simpleField "exec_timestamp" [t| Timestamp |] + , optionalNullSerField $ + simpleField "end_timestamp" [t| Timestamp |] + ]) + +$(buildObject "QueuedJob" "qj" + [ simpleField "id" [t| JobId |] + , simpleField "ops" [t| [QueuedOpCode] |] + , optionalNullSerField $ + simpleField "received_timestamp" [t| Timestamp |] + , optionalNullSerField $ + simpleField "start_timestamp" [t| Timestamp |] + , optionalNullSerField $ + simpleField "end_timestamp" [t| Timestamp |] + ]) + +-- | Job file prefix. +jobFilePrefix :: String +jobFilePrefix = "job-" + +-- | Computes the filename for a given job ID. +jobFileName :: JobId -> FilePath +jobFileName jid = jobFilePrefix ++ show (fromJobId jid) + +-- | Parses a job ID from a file name. +parseJobFileId :: (Monad m) => FilePath -> m JobId +parseJobFileId path = + case stripPrefix jobFilePrefix path of + Nothing -> fail $ "Job file '" ++ path ++ + "' doesn't have the correct prefix" + Just suffix -> makeJobIdS suffix + +-- | Computes the full path to a live job. +liveJobFile :: FilePath -> JobId -> FilePath +liveJobFile rootdir jid = rootdir jobFileName jid + +-- | Computes the full path to an archives job. BROKEN. +archivedJobFile :: FilePath -> JobId -> FilePath +archivedJobFile rootdir jid = + let subdir = show (fromJobId jid `div` C.jstoreJobsPerArchiveDirectory) + in rootdir jobQueueArchiveSubDir subdir jobFileName jid + +-- | Map from opcode status to job status. +opStatusToJob :: OpStatus -> JobStatus +opStatusToJob OP_STATUS_QUEUED = JOB_STATUS_QUEUED +opStatusToJob OP_STATUS_WAITING = JOB_STATUS_WAITING +opStatusToJob OP_STATUS_SUCCESS = JOB_STATUS_SUCCESS +opStatusToJob OP_STATUS_RUNNING = JOB_STATUS_RUNNING +opStatusToJob OP_STATUS_CANCELING = JOB_STATUS_CANCELING +opStatusToJob OP_STATUS_CANCELED = JOB_STATUS_CANCELED +opStatusToJob OP_STATUS_ERROR = JOB_STATUS_ERROR + +-- | Computes a queued job's status. +calcJobStatus :: QueuedJob -> JobStatus +calcJobStatus QueuedJob { qjOps = ops } = + extractOpSt (map qoStatus ops) JOB_STATUS_QUEUED True + where + terminalStatus OP_STATUS_ERROR = True + terminalStatus OP_STATUS_CANCELING = True + terminalStatus OP_STATUS_CANCELED = True + terminalStatus _ = False + softStatus OP_STATUS_SUCCESS = True + softStatus OP_STATUS_QUEUED = True + softStatus _ = False + extractOpSt [] _ True = JOB_STATUS_SUCCESS + extractOpSt [] d False = d + extractOpSt (x:xs) d old_all + | terminalStatus x = opStatusToJob x -- abort recursion + | softStatus x = extractOpSt xs d new_all -- continue unchanged + | otherwise = extractOpSt xs (opStatusToJob x) new_all + where new_all = x == OP_STATUS_SUCCESS && old_all + +-- | Determine whether an opcode status is finalized. +opStatusFinalized :: OpStatus -> Bool +opStatusFinalized = (> OP_STATUS_RUNNING) + +-- | Compute a job's priority. +calcJobPriority :: QueuedJob -> Int +calcJobPriority QueuedJob { qjOps = ops } = + helper . map qoPriority $ filter (not . opStatusFinalized . qoStatus) ops + where helper [] = C.opPrioDefault + helper ps = minimum ps + +-- | Log but ignore an 'IOError'. +ignoreIOError :: a -> Bool -> String -> IOError -> IO a +ignoreIOError a ignore_noent msg e = do + unless (isDoesNotExistError e && ignore_noent) . + logWarning $ msg ++ ": " ++ show e + return a + +-- | Compute the list of existing archive directories. Note that I/O +-- exceptions are swallowed and ignored. +allArchiveDirs :: FilePath -> IO [FilePath] +allArchiveDirs rootdir = do + let adir = rootdir jobQueueArchiveSubDir + contents <- getDirectoryContents adir `Control.Exception.catch` + ignoreIOError [] False + ("Failed to list queue directory " ++ adir) + let fpaths = map (adir ) $ filter (not . ("." `isPrefixOf`)) contents + filterM (\path -> + liftM isDirectory (getFileStatus (adir path)) + `Control.Exception.catch` + ignoreIOError False True + ("Failed to stat archive path " ++ path)) fpaths + +-- | Build list of directories containing job files. Note: compared to +-- the Python version, this doesn't ignore a potential lost+found +-- file. +determineJobDirectories :: FilePath -> Bool -> IO [FilePath] +determineJobDirectories rootdir archived = do + other <- if archived + then allArchiveDirs rootdir + else return [] + return $ rootdir:other + +-- | Computes the list of all jobs in the given directories. +getJobIDs :: [FilePath] -> IO [JobId] +getJobIDs = liftM concat . mapM getDirJobIDs + +-- | Sorts the a list of job IDs. +sortJobIDs :: [JobId] -> [JobId] +sortJobIDs = sortBy (comparing fromJobId) + +-- | Computes the list of jobs in a given directory. +getDirJobIDs :: FilePath -> IO [JobId] +getDirJobIDs path = do + contents <- getDirectoryContents path `Control.Exception.catch` + ignoreIOError [] False + ("Failed to list job directory " ++ path) + let jids = foldl (\ids file -> + case parseJobFileId file of + Nothing -> ids + Just new_id -> new_id:ids) [] contents + return $ reverse jids + +-- | Reads the job data from disk. +readJobDataFromDisk :: FilePath -> Bool -> JobId -> IO (Maybe (String, Bool)) +readJobDataFromDisk rootdir archived jid = do + let live_path = liveJobFile rootdir jid + archived_path = archivedJobFile rootdir jid + all_paths = if archived + then [(live_path, False), (archived_path, True)] + else [(live_path, False)] + foldM (\state (path, isarchived) -> + liftM (\r -> Just (r, isarchived)) (readFile path) + `Control.Exception.catch` + ignoreIOError state True + ("Failed to read job file " ++ path)) Nothing all_paths + +-- | Failed to load job error. +noSuchJob :: Result (QueuedJob, Bool) +noSuchJob = Bad "Can't load job file" + +-- | Loads a job from disk. +loadJobFromDisk :: FilePath -> Bool -> JobId -> IO (Result (QueuedJob, Bool)) +loadJobFromDisk rootdir archived jid = do + raw <- readJobDataFromDisk rootdir archived jid + -- note: we need some stricness below, otherwise the wrapping in a + -- Result will create too much lazyness, and not close the file + -- descriptors for the individual jobs + return $! case raw of + Nothing -> noSuchJob + Just (str, arch) -> + liftM (\qj -> (qj, arch)) . + fromJResult "Parsing job file" $ Text.JSON.decode str -- 1.7.10.4