mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

added push notifier thread, currently a no-op

Browse source 
Hooked up everything that needs to notify on pushes. Note that
syncNewRemote does not notify. This is probably ok, and I'd need to thread
more state through to make it do so.

This is only set up to support a single push notification method; I didn't
use a NotificationBroadcaster. Partly because I don't yet know what info
about pushes needs to be communicated, so my data types are only
preliminary.
This commit is contained in:
Joey Hess 2012-10-24 13:35:43 -04:00
parent 6b6ce30b42
commit ae8a3ab31e
7 changed files with 100 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

20
Assistant/Sync.hs
View file

@ -36,9 +36,9 @@ 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 -> [Remote] -> IO ()
reconnectRemotes _ _ _ _ [] = noop
reconnectRemotes threadname st dstatus scanremotes rs = void $
reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Maybe PushNotifier -> [Remote] -> IO ()
reconnectRemotes _ _ _ _ _ [] = noop
reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
alertWhile dstatus (syncAlert rs) $ do
(ok, diverged) <- sync
=<< runThreadState st (inRepo Git.Branch.current)
@ -50,7 +50,7 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
sync (Just branch) = do
diverged <- manualPull st (Just branch) gitremotes
now <- getCurrentTime
ok <- pushToRemotes threadname now st Nothing gitremotes
ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes
return (ok, diverged)
{- No local branch exists yet, but we can try pulling. -}
sync Nothing = do
@ -81,8 +81,8 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
- them. While ugly, those branches are reserved for pushing by us, and
- so our pushes will succeed.
-}
pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe FailedPushMap -> [Remote] -> IO Bool
pushToRemotes threadname now st mpushmap remotes = do
pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe PushNotifier -> Maybe FailedPushMap -> [Remote] -> IO Bool
pushToRemotes threadname now st mpushnotifier mpushmap remotes = do
(g, branch, u) <- runThreadState st $ (,,)
<$> gitRepo
<*> inRepo Git.Branch.current
@ -100,7 +100,9 @@ pushToRemotes threadname now st mpushmap remotes = do
updatemap succeeded []
let ok = null failed
if ok
then return ok
then do
maybe noop notifyPush mpushnotifier
return ok
else if shouldretry
then retry branch g u failed
else fallback branch g u failed
@ -124,6 +126,8 @@ pushToRemotes threadname now st mpushmap remotes = do
]
(succeeded, failed) <- inParallel (pushfallback g u branch) rs
updatemap succeeded failed
unless (null succeeded) $
maybe noop notifyPush mpushnotifier
return $ null failed
push g branch remote = Command.Sync.pushBranch remote branch g
@ -157,4 +161,4 @@ manualPull st currentbranch remotes = do
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
syncNewRemote st dstatus scanremotes remote = do
runThreadState st $ updateSyncRemotes dstatus
void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]
void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes Nothing [remote]