log migration trees to git-annex branch
This will allow distributed migration: Start a migration in one clone of a repo, and then update other clones. commitMigration is a bit of a bear.. There is some inversion of control that needs some TMVars. Also streamLogFile's finalizer does not handle recording the trees, so an interrupt at just the wrong time can cause migration.log to be emptied but the git-annex branch not updated. Sponsored-by: Graham Spencer on Patreon
This commit is contained in:
parent
b55efc179a
commit
0bd8b17b59
12 changed files with 219 additions and 43 deletions
|
@ -19,6 +19,7 @@ module Utility.CoProcess (
|
|||
import Common
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
|
||||
type CoProcessHandle = MVar CoProcessState
|
||||
|
||||
|
@ -65,11 +66,11 @@ stop ch = do
|
|||
{- To handle a restartable process, any IO exception thrown by the send and
|
||||
- receive actions are assumed to mean communication with the process
|
||||
- failed, and the failed action is re-run with a new process. -}
|
||||
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
|
||||
query :: (MonadIO m, MonadCatch m) => CoProcessHandle -> (Handle -> m a) -> (Handle -> m b) -> m b
|
||||
query ch send receive = do
|
||||
s <- readMVar ch
|
||||
s <- liftIO $ readMVar ch
|
||||
restartable s (send $ coProcessTo s) $ const $
|
||||
restartable s (hFlush $ coProcessTo s) $ const $
|
||||
restartable s (liftIO $ hFlush $ coProcessTo s) $ const $
|
||||
restartable s (receive $ coProcessFrom s)
|
||||
return
|
||||
where
|
||||
|
@ -78,12 +79,12 @@ query ch send receive = do
|
|||
maybe restart cont =<< catchMaybeIO a
|
||||
| otherwise = cont =<< a
|
||||
restart = do
|
||||
s <- takeMVar ch
|
||||
void $ catchMaybeIO $ do
|
||||
s <- liftIO $ takeMVar ch
|
||||
void $ liftIO $ catchMaybeIO $ do
|
||||
hClose $ coProcessTo s
|
||||
hClose $ coProcessFrom s
|
||||
void $ waitForProcess $ coProcessPid s
|
||||
s' <- start' $ (coProcessSpec s)
|
||||
void $ liftIO $ waitForProcess $ coProcessPid s
|
||||
s' <- liftIO $ start' $ (coProcessSpec s)
|
||||
{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
|
||||
putMVar ch s'
|
||||
liftIO $ putMVar ch s'
|
||||
query ch send receive
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue