flush keys db queue even on exception

Also fixed a bug in makeRunner; run' leaves the mvar empty so have to
refill it.
This commit is contained in:
Joey Hess 2015-12-23 19:38:18 -04:00
parent 4224fae71f
commit f839d407e3
Failed to extract signature

View file

@ -201,9 +201,12 @@ run s a = flip run' a =<< newMVar s
run' :: MVar AnnexState -> Annex a -> IO (a, AnnexState) run' :: MVar AnnexState -> Annex a -> IO (a, AnnexState)
run' mvar a = do run' mvar a = do
r <- runReaderT (runAnnex a) mvar r <- runReaderT (runAnnex a) mvar
`onException` (flush =<< readMVar mvar)
s' <- takeMVar mvar s' <- takeMVar mvar
maybe noop Keys.flushDbQueue (keysdbhandle s') flush s'
return (r, s') return (r, s')
where
flush = maybe noop Keys.flushDbQueue . keysdbhandle
{- Performs an action in the Annex monad from a starting state, {- Performs an action in the Annex monad from a starting state,
- and throws away the new 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 :: Annex (Annex a -> IO a)
makeRunner = do makeRunner = do
mvar <- ask 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 :: (AnnexState -> v) -> Annex v
getState selector = do getState selector = do