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:
parent
4224fae71f
commit
f839d407e3
1 changed files with 8 additions and 2 deletions
10
Annex.hs
10
Annex.hs
|
@ -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
|
||||||
|
|
Loading…
Add table
Reference in a new issue