From 7c30af770b98a0459f65b9bfff37f35b5da0835d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 23 Dec 2015 19:38:18 -0400 Subject: flush keys db queue even on exception Also fixed a bug in makeRunner; run' leaves the mvar empty so have to refill it. --- Annex.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'Annex.hs') diff --git a/Annex.hs b/Annex.hs index a8368f81e..4f26c497c 100644 --- a/Annex.hs +++ b/Annex.hs @@ -201,9 +201,12 @@ run s a = flip run' a =<< newMVar s run' :: MVar AnnexState -> Annex a -> IO (a, AnnexState) run' mvar a = do r <- runReaderT (runAnnex a) mvar + `onException` (flush =<< readMVar mvar) s' <- takeMVar mvar - maybe noop Keys.flushDbQueue (keysdbhandle s') + flush s' return (r, s') + where + flush = maybe noop Keys.flushDbQueue . keysdbhandle {- Performs an action in the Annex monad from a starting state, - and throws away the new state. -} @@ -215,7 +218,10 @@ eval s a = fst <$> run s a makeRunner :: Annex (Annex a -> IO a) makeRunner = do mvar <- ask - return $ \a -> fst <$> run' mvar a + return $ \a -> do + (r, s) <- run' mvar a + putMVar mvar s + return r getState :: (AnnexState -> v) -> Annex v getState selector = do -- cgit v1.2.3