lifted Assistant.Sync into Assistant monad

lots of nice cleanups
This commit is contained in:
Joey Hess 2012-10-29 16:22:14 -04:00
parent 1948202b32
commit 5d57b28a34
9 changed files with 88 additions and 117 deletions

View file

@ -36,25 +36,29 @@ import Control.Concurrent
- the remotes have diverged from the local git-annex branch. Otherwise,
- it's sufficient to requeue failed transfers.
-}
reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Maybe PushNotifier -> [Remote] -> IO ()
reconnectRemotes _ _ _ _ _ [] = noop
reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
alertWhile dstatus (syncAlert rs) $ do
reconnectRemotes :: Bool -> [Remote] -> Assistant ()
reconnectRemotes _ [] = noop
reconnectRemotes notifypushes rs = void $ do
dstatus <- getAssistant daemonStatusHandle
alertWhile dstatus (syncAlert rs) <~> do
(ok, diverged) <- sync
=<< runThreadState st (inRepo Git.Branch.current)
addScanRemotes scanremotes diverged rs
=<< liftAnnex (inRepo Git.Branch.current)
scanremotes <- getAssistant scanRemoteMap
liftIO $ addScanRemotes scanremotes diverged rs
return ok
where
(gitremotes, _specialremotes) =
partition (Git.repoIsUrl . Remote.repo) rs
sync (Just branch) = do
diverged <- snd <$> manualPull st (Just branch) gitremotes
now <- getCurrentTime
ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes
st <- getAssistant threadState
diverged <- liftIO $ snd <$> manualPull st (Just branch) gitremotes
now <- liftIO getCurrentTime
ok <- pushToRemotes now notifypushes gitremotes
return (ok, diverged)
{- No local branch exists yet, but we can try pulling. -}
sync Nothing = do
diverged <- snd <$> manualPull st Nothing gitremotes
st <- getAssistant threadState
diverged <- liftIO $ snd <$> manualPull st Nothing gitremotes
return (True, diverged)
{- Updates the local sync branch, then pushes it to all remotes, in
@ -81,72 +85,68 @@ reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
- them. While ugly, those branches are reserved for pushing by us, and
- so our pushes will succeed.
-}
pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe PushNotifier -> Maybe FailedPushMap -> [Remote] -> IO Bool
pushToRemotes threadname now st mpushnotifier mpushmap remotes = do
(g, branch, u) <- runThreadState st $ do
pushToRemotes :: UTCTime -> Bool -> [Remote] -> Assistant Bool
pushToRemotes now notifypushes remotes = do
(g, branch, u) <- liftAnnex $ do
Annex.Branch.commit "update"
(,,)
<$> gitRepo
<*> inRepo Git.Branch.current
<*> getUUID
go True branch g u remotes
where
go _ Nothing _ _ _ = return True -- no branch, so nothing to do
go shouldretry (Just branch) g u rs = do
brokendebug threadname
[ "pushing to"
, show rs
where
go _ Nothing _ _ _ = return True -- no branch, so nothing to do
go shouldretry (Just branch) g u rs = do
debug ["pushing to", show rs]
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
(succeeded, failed) <- liftIO $ inParallel (push g branch) rs
updatemap succeeded []
if null failed
then do
when notifypushes $
notifyPush (map Remote.uuid succeeded) <<~ pushNotifier
return True
else if shouldretry
then retry branch g u failed
else fallback branch g u failed
updatemap succeeded failed = do
pushmap <- getAssistant failedPushMap
liftIO $ changeFailedPushMap pushmap $ \m ->
M.union (makemap failed) $
M.difference m (makemap succeeded)
makemap l = M.fromList $ zip l (repeat now)
retry branch g u rs = do
debug ["trying manual pull to resolve failed pushes"]
st <- getAssistant threadState
void $ liftIO $ manualPull st (Just branch) rs
go False (Just branch) g u rs
fallback branch g u rs = do
debug ["fallback pushing to", show rs]
(succeeded, failed) <- liftIO $
inParallel (pushfallback g u branch) rs
updatemap succeeded failed
when (notifypushes && (not $ null succeeded)) $
notifyPush (map Remote.uuid succeeded) <<~ pushNotifier
return $ null failed
push g branch remote = Command.Sync.pushBranch remote branch g
pushfallback g u branch remote = Git.Command.runBool "push"
[ Param $ Remote.name remote
, Param $ refspec Annex.Branch.name
, Param $ refspec branch
] g
where
{- Push to refs/synced/uuid/branch; this
- avoids cluttering up the branch display. -}
refspec b = concat
[ s
, ":"
, "refs/synced/" ++ fromUUID u ++ "/" ++ s
]
Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
(succeeded, failed) <- inParallel (push g branch) rs
updatemap succeeded []
let ok = null failed
if ok
then do
maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier
return ok
else if shouldretry
then retry branch g u failed
else fallback branch g u failed
updatemap succeeded failed = case mpushmap of
Nothing -> noop
Just pushmap -> changeFailedPushMap pushmap $ \m ->
M.union (makemap failed) $
M.difference m (makemap succeeded)
makemap l = M.fromList $ zip l (repeat now)
retry branch g u rs = do
brokendebug threadname [ "trying manual pull to resolve failed pushes" ]
void $ manualPull st (Just branch) rs
go False (Just branch) g u rs
fallback branch g u rs = do
brokendebug threadname
[ "fallback pushing to"
, show rs
]
(succeeded, failed) <- inParallel (pushfallback g u branch) rs
updatemap succeeded failed
unless (null succeeded) $
maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier
return $ null failed
push g branch remote = Command.Sync.pushBranch remote branch g
pushfallback g u branch remote = Git.Command.runBool "push"
[ Param $ Remote.name remote
, Param $ refspec Annex.Branch.name
, Param $ refspec branch
] g
where
{- Push to refs/synced/uuid/branch; this
- avoids cluttering up the branch display. -}
refspec b = concat
[ s
, ":"
, "refs/synced/" ++ fromUUID u ++ "/" ++ s
]
where s = show $ Git.Ref.base b
where s = show $ Git.Ref.base b
{- Manually pull from remotes and merge their branches. -}
manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO ([Bool], Bool)
@ -160,7 +160,8 @@ manualPull st currentbranch remotes = do
return (results, haddiverged)
{- Start syncing a newly added remote, using a background thread. -}
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
syncNewRemote st dstatus scanremotes remote = do
runThreadState st $ updateSyncRemotes dstatus
void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes Nothing [remote]
syncNewRemote :: Remote -> Assistant ()
syncNewRemote remote = do
liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
thread <- asIO2 reconnectRemotes
void $ liftIO $ forkIO $ thread False [remote]