pull from one of the remotes in a push notification

Still need to do something about transfer queueing, however. This could be
a real can of worms.

2 files changed, 32 insertions, 10 deletions

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index f9a513d94..e332d7856 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -48,13 +48,13 @@ reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
 		(gitremotes, _specialremotes) =
 			partition (Git.repoIsUrl . Remote.repo) rs
 		sync (Just branch) = do
-			diverged <- manualPull st (Just branch) gitremotes
+			diverged <- snd <$> manualPull st (Just branch) gitremotes
 			now <- getCurrentTime
 			ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes
 			return (ok, diverged)
 		{- No local branch exists yet, but we can try pulling. -}
 		sync Nothing = do
-			diverged <- manualPull st Nothing gitremotes
+			diverged <- snd <$> manualPull st Nothing gitremotes
 			return (True, diverged)
 
 {- Updates the local sync branch, then pushes it to all remotes, in
@@ -147,15 +147,15 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do
 					where s = show $ Git.Ref.base b
 
 {- Manually pull from remotes and merge their branches. -}
-manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool
+manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO ([Bool], Bool)
 manualPull st currentbranch remotes = do
 	g <- runThreadState st gitRepo
-	forM_ remotes $ \r ->
+	results <- forM remotes $ \r ->
 		Git.Command.runBool "fetch" [Param $ Remote.name r] g
 	haddiverged <- runThreadState st Annex.Branch.forceUpdate
 	forM_ remotes $ \r ->
 		runThreadState st $ Command.Sync.mergeRemote r currentbranch
-	return haddiverged
+	return (results, haddiverged)
 
 {- Start syncing a newly added remote, using a background thread. -}
 syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs
index 12cbb3206..8d761dc55 100644
--- a/Assistant/Threads/PushNotifier.hs
+++ b/Assistant/Threads/PushNotifier.hs
@@ -14,6 +14,7 @@ import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.Pushes
+import Assistant.Sync
 import qualified Remote
 
 import Network.Protocol.XMPP
@@ -22,6 +23,7 @@ import Control.Concurrent
 import qualified Data.Text as T
 import qualified Data.Set as S
 import Utility.FileMode
+import qualified Git.Branch
 
 thisThread :: ThreadName
 thisThread = "PushNotifier"
@@ -62,7 +64,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do
 			s <- getStanza
 			case s of
 				ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) ->
-					 maybe noop (liftIO . pull dstatus)
+					 maybe noop (liftIO . pull st dstatus)
 						(decodePushNotification t)
 				_ -> noop
 
@@ -118,11 +120,31 @@ decodePushNotification :: T.Text -> Maybe [UUID]
 decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim
 	<$> T.stripPrefix prefix t
 
-pull :: DaemonStatusHandle -> [UUID] -> IO ()
-pull _ [] = noop
-pull dstatus us = do
+{- We only pull from one remote out of the set listed in the push
+ - notification, as an optimisation.
+ -
+ - Note that it might be possible (though very unlikely) for the push
+ - notification to take a while to be sent, and multiple pushes happen
+ - before it is sent, so it includes multiple remotes that were pushed
+ - to at different times. 
+ -
+ - It could then be the case that the remote we choose had the earlier
+ - push sent to it, but then failed to get the later push, and so is not
+ - fully up-to-date. If that happens, the pushRetryThread will come along
+ - and retry the push, and we'll get another notification once it succeeds,
+ - and pull again. -}
+pull :: ThreadState -> DaemonStatusHandle -> [UUID] -> IO ()
+pull _ _ [] = noop
+pull st dstatus us = do
 	rs <- filter matching . syncRemotes <$> getDaemonStatus dstatus
-	print ("TODO pull from", rs)
+	debug thisThread $ "push notification for" :
+		map (fromUUID . Remote.uuid ) rs
+	pullone rs =<< runThreadState st (inRepo Git.Branch.current)
 	where
 		matching r = Remote.uuid r `S.member` s
 		s = S.fromList us
+
+		pullone [] _ = noop
+		pullone (r:rs) branch =
+			unlessM (all id . fst <$> manualPull st branch [r]) $
+				pullone rs branch