I'm a little bit concerned about releasing the MVar lock in the case of an
exception. If something bad happens, not just the thread dies, but the
whole server can get stuck on an unreleased lock. And it's also slightly
more difficult to maintain.
I was thinking how we could use "bracket" or "try" and and the same time
to release the lock before issuing the RPC call. I believe we could use
ResultT to help. Here is my idea:
handleCall qlock _ cfg (ArchiveJob jid) =
liftM (return . showJSON . genericResult (const False) id) . runResultT $
do
qDir <- liftIO $ queueDir
(mcs, live, archive) <- bracketT_ (takeMVar qlock) (putMVar qlock ()) $
do
(job, _) <- ResultT $ loadJobFromDisk qDir False jid
guard $ jobFinalized job
let mcs = Config.getMasterCandidates cfg
live = liveJobFile qDir jid
archive = archivedJobFile qDir jid
liftIO $ renameFile live archive
return (mcs, live, archive)
_ <- liftIO $ executeRpcCall mcs $ RpcCallJobqueueRename [(live,
archive)]
return True
where
bracketT_ :: IO a -> IO b -> ResultT e IO c -> ResultT e IO c
bracketT_ start end = ResultT . bracket_ start end . runResultT
(I haven't tested the code, I just compiled it.)
I have been thinking lately how to ease error handling with multiple nested
Results etc., and I made a few helper functions that helped me to use
ResultT more easily, primarily for converting different types of errors
(like to get rid of the not-very-nice genericResult above). I tried to
refactor a few code pieces to see how well it works. But I haven't pushed
them yet, hopefully very soon.
Best,
Petr
On Wed, Jan 22, 2014 at 3:00 PM, 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 | 20 ++++++++++++++++++++
> 1 file changed, 20 insertions(+)
>
> diff --git a/src/Ganeti/Query/Server.hs b/src/Ganeti/Query/Server.hs
> index ae8fcc5..8d48c95 100644
> --- a/src/Ganeti/Query/Server.hs
> +++ b/src/Ganeti/Query/Server.hs
> @@ -334,6 +334,26 @@ 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
> + renameFile live archive
> + putMVar qlock ()
> + _ <- 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
>
>
