Related: I've been looking into the concept of MonadBaseControl lately, which allows to lift IO functions like bracket, forkIO etc. into many monad transformers, including our ResultT: http://hackage.haskell.org/package/lifted-base-0.2.1.1/docs/Control-Exception-Lifted.html or http://hackage.haskell.org/package/lifted-base-0.2.1.1/docs/Control-Concurrent-MVar-Lifted.html
It'd possible to define instances for ResultT and use it in our IO-based code. This would allow us to use all these functions (like bracket) in ResultT, or other transformers such as ReaderT. It'd simplify some parts of the RPC/daemons stuff. In particular, I'd like the RPC not to be dependent on a particular monad, but it needs to be able to fork threads. I just want to do a few more tests to be sure it all works as we need. But since it got into wheezy (+ for us) and is used by heavy production libraries < http://packdeps.haskellers.com/reverse/lifted-base>, I believe there will be no problems with it. Best, Petr On Wed, Jan 22, 2014 at 7:23 PM, Petr Pudlák <[email protected]> wrote: > 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 >> >> >
