diff --git a/Makefile.am b/Makefile.am
index 2f95d16ebd1ce72db2f853e0930e0c2c07a756cd..cd76ac70d9248490ac8e75f307f907640f69cb94 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 0000000000000000000000000000000000000000..29f525a356275e6a0fc1b9b704dddd6698556010
--- /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 3bb1294c6ef0f0337c8cf3b2f3cb079c6fe6ca76..d7848aa04f2b6793b9275a388c6f144142b6fd15 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 0000000000000000000000000000000000000000..39aa3fc604009f9354af9a726f8422fe428d3976
--- /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