summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-12-23 19:38:18 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-12-23 19:38:18 -0400
commit7c30af770b98a0459f65b9bfff37f35b5da0835d (patch)
treef59e424c19692c6dc2b9d81e77ee9726da2f3c10
parentf4af69bdffbfa143aaca7971ddab6117dc684426 (diff)
flush keys db queue even on exception
Also fixed a bug in makeRunner; run' leaves the mvar empty so have to refill it.
-rw-r--r--Annex.hs10
1 files changed, 8 insertions, 2 deletions
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