Good idea! I'm also in favor of using sum types for error handling. Maybe we could add it as a HaskellTask, to review the code for functions in IO if they handle all exceptions properly.
LGTM, thanks. (I'm still a bit concerned from the maintainability point of view - it's better if the portion holding a lock is clearly delimited, so that it's obvious that the lock is always released without having to check all code paths, but I don't think it's a reason for blocking the patch.) On Thu, Jan 23, 2014 at 10:38 AM, Klaus Aehlig <[email protected]> wrote: > With luxid taking over the tasks of masterd, archiving > jobs also belongs to its responsibilities. As archiving > a job affects the global state of the job queue, synchronise > over the queue lock. > > Signed-off-by: Klaus Aehlig <[email protected]> > --- > src/Ganeti/Query/Server.hs | 26 ++++++++++++++++++++++++++ > 1 file changed, 26 insertions(+) > > diff --git a/src/Ganeti/Query/Server.hs b/src/Ganeti/Query/Server.hs > index ae8fcc5..64b49f9 100644 > --- a/src/Ganeti/Query/Server.hs > +++ b/src/Ganeti/Query/Server.hs > @@ -334,6 +334,32 @@ handleCall _ qstat cfg (CancelJob jid) = do > cancelJob jid > Bad s -> return . Ok . showJSON $ (False, s) > > +handleCall qlock _ cfg (ArchiveJob jid) = do > + let archiveFailed = putMVar qlock () >> (return . Ok $ showJSON False) > + :: IO (ErrorResult JSValue) > + qDir <- queueDir > + takeMVar qlock > + result <- loadJobFromDisk qDir False jid > + case result of > + Bad _ -> archiveFailed > + Ok (job, _) -> if jobFinalized job > + then do > + let mcs = Config.getMasterCandidates cfg > + live = liveJobFile qDir jid > + archive = archivedJobFile qDir jid > + renameResult <- try $ renameFile live archive > + :: IO (Either IOError ()) > + putMVar qlock () > + case renameResult of > + Left e -> return . Bad . JobQueueError > + $ "Archiving failed in an unexpected > way: " > + ++ show e > + Right () -> do > + _ <- executeRpcCall mcs > + $ RpcCallJobqueueRename [(live, > archive)] > + return . Ok $ showJSON True > + else archiveFailed > + > handleCall _ _ _ op = > return . Bad $ > GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented") > -- > 1.8.5.3 > >
