don't try to transfer data to/from XMPP remotes

Partition syncRemotes into ones needing git sync (ie, non-special remotes),
and ones needing data sync (ie, non-XMPP remotes).

Assistant/DaemonStatus.hs

@@ -10,11 +10,13 @@ module Assistant.DaemonStatus where
 import Assistant.Common
 import Assistant.Alert
 import Utility.TempFile
+import Assistant.Types.NetMessager
 import Utility.NotificationBroadcaster
 import Logs.Transfer
 import Logs.Trust
 import qualified Remote
 import qualified Types.Remote as Remote
+import qualified Git
 import Config
 
 import Control.Concurrent.STM
@@ -23,6 +25,7 @@ import Data.Time.Clock.POSIX
 import Data.Time
 import System.Locale
 import qualified Data.Map as M
+import qualified Data.Text as T
 
 getDaemonStatus :: Assistant DaemonStatus
 getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
@@ -41,20 +44,23 @@ modifyDaemonStatus a = do
 		sendNotification $ changeNotifier s
 		return b
 
-{- Syncable remotes ordered by cost. -}
+{- Returns a function that updates the lists of syncable remotes. -}
-calcSyncRemotes :: Annex [Remote]
+calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
 calcSyncRemotes = do
 	rs <- filterM (repoSyncable . Remote.repo) =<<
 		concat . Remote.byCost <$> Remote.enabledRemoteList
 	alive <- trustExclude DeadTrusted (map Remote.uuid rs)
 	let good r = Remote.uuid r `elem` alive
-	return $ filter good rs
+	let syncable = filter good rs
+	return $ \dstatus -> dstatus
+		{ syncRemotes = syncable
+		, syncGitRemotes = filter (not . Remote.specialRemote) syncable
+		, syncDataRemotes = filter (not . isXMPPRemote) syncable
+		}
 
 {- Updates the sycRemotes list from the list of all remotes in Annex state. -}
 updateSyncRemotes :: Assistant ()
-updateSyncRemotes = do
+updateSyncRemotes = modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
-	remotes <- liftAnnex calcSyncRemotes
-	modifyDaemonStatus_ $ \s -> s { syncRemotes = remotes }
 
 {- Load any previous daemon status file, and store it in a MVar for this
  - process to use as its DaemonStatus. Also gets current transfer status. -}
@@ -64,12 +70,11 @@ startDaemonStatus = do
 	status <- liftIO $
 		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
 	transfers <- M.fromList <$> getTransfers
-	remotes <- calcSyncRemotes
+	addsync <- calcSyncRemotes
-	liftIO $ atomically $ newTMVar status
+	liftIO $ atomically $ newTMVar $ addsync $ status
 		{ scanComplete = False
 		, sanityCheckRunning = False
 		, currentTransfers = transfers
-		, syncRemotes = remotes
 		}
 
 {- Don't just dump out the structure, because it will change over time,
@@ -221,3 +226,12 @@ alertDuring :: Alert -> Assistant a -> Assistant a
 alertDuring alert a = do
 	i <- addAlert $ alert { alertClass = Activity }
 	removeAlert  i `after` a
+
+{- Remotes using the XMPP transport have urls like xmpp::user@host -}
+isXMPPRemote :: Remote -> Bool
+isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
+  where
+	r = Remote.repo remote
+
+getXMPPClientID :: Remote -> ClientID
+getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/Drop.hs

@@ -23,7 +23,7 @@ import Config
 handleDrops :: Bool -> Key -> AssociatedFile -> Assistant ()
 handleDrops _ _ Nothing = noop
 handleDrops fromhere key f = do
-	syncrs <- syncRemotes <$> getDaemonStatus
+	syncrs <- syncDataRemotes <$> getDaemonStatus
 	liftAnnex $ do
 		locs <- loggedLocations key
 		handleDrops' locs syncrs fromhere key f

Assistant/NetMessager.hs

@@ -95,12 +95,3 @@ queueNetPushMessage _ = return False
 waitNetPushMessage :: PushSide -> Assistant (NetMessage)
 waitNetPushMessage side = (atomically . readTChan)
 	<<~ (getSide side . netMessagesPush . netMessager)
-
-{- Remotes using the XMPP transport have urls like xmpp::user@host -}
-isXMPPRemote :: Remote -> Bool
-isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
-  where
-	r = Remote.repo remote
-
-getXMPPClientID :: Remote -> ClientID
-getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/Threads/Pusher.hs

@@ -15,7 +15,6 @@ import Assistant.Alert
 import Assistant.DaemonStatus
 import Assistant.Sync
 import Utility.ThreadScheduler
-import qualified Remote
 import qualified Types.Remote as Remote
 
 import Data.Time.Clock
@@ -46,7 +45,8 @@ pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do
 	-- Now see if now's a good time to push.
 	if shouldPush commits
 		then do
-			remotes <- filter pushable . syncRemotes <$> getDaemonStatus
+			remotes <- filter (not . Remote.readonly) 
+				. syncGitRemotes <$> getDaemonStatus
 			unless (null remotes) $
 				void $ alertWhile (pushAlert remotes) $ do
 					now <- liftIO $ getCurrentTime
@@ -54,11 +54,6 @@ pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do
 		else do
 			debug ["delaying push of", show (length commits), "commits"]
 			refillCommits commits
-  where
-	pushable r
-		| Remote.specialRemote r = False
-		| Remote.readonly r = False
-		| otherwise = True
 
 {- Decide if now is a good time to push to remotes.
  -

Assistant/Threads/TransferScanner.hs

@@ -57,7 +57,7 @@ transferScannerThread = NamedThread "TransferScanner" $ do
 	 -   and then the system (or us) crashed, and that info was
 	 -   lost.
 	 -}
-	startupScan = addScanRemotes True =<< syncRemotes <$> getDaemonStatus
+	startupScan = addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus
 
 {- This is a cheap scan for failed transfers involving a remote. -}
 failedTransferScan :: Remote -> Assistant ()
@@ -114,7 +114,7 @@ expensiveScan rs = unless onlyweb $ do
 	findtransfers f (key, _) = do
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
-		syncrs <- syncRemotes <$> getDaemonStatus
+		syncrs <- syncDataRemotes <$> getDaemonStatus
 		liftAnnex $ do
 			locs <- loggedLocations key
 			present <- inAnnex key

Assistant/Threads/XMPPClient.hs

@@ -190,7 +190,7 @@ xmppThread a = do
 pull :: [UUID] -> Assistant ()
 pull [] = noop
 pull us = do
-	rs <- filter matching . syncRemotes <$> getDaemonStatus
+	rs <- filter matching . syncGitRemotes <$> getDaemonStatus
 	debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
 	pullone rs =<< liftAnnex (inRepo Git.Branch.current)
   where

Assistant/TransferQueue.hs

@@ -57,7 +57,7 @@ queueTransfersMatching matching schedule k f direction
   where
 	go = do
 		rs <- liftAnnex . sufficientremotes
-			=<< syncRemotes <$> getDaemonStatus
+			=<< syncDataRemotes <$> getDaemonStatus
 		let matchingrs = filter (matching . Remote.uuid) rs
 		if null matchingrs
 			then defer
@@ -94,7 +94,7 @@ queueDeferredDownloads :: Schedule -> Assistant ()
 queueDeferredDownloads schedule = do
 	q <- getAssistant transferQueue
 	l <- liftIO $ atomically $ swapTVar (deferreddownloads q) []
-	rs <- syncRemotes <$> getDaemonStatus
+	rs <- syncDataRemotes <$> getDaemonStatus
 	left <- filterM (queue rs) l
 	unless (null left) $
 		liftIO $ atomically $ modifyTVar' (deferreddownloads q) $

Assistant/Types/DaemonStatus.hs

@@ -33,8 +33,12 @@ data DaemonStatus = DaemonStatus
 	-- Messages to display to the user.
 	, alertMap :: AlertMap
 	, lastAlertId :: AlertId
-	-- Ordered list of remotes to sync with.
+	-- Ordered list of all remotes that can be synced with
 	, syncRemotes :: [Remote]
+	-- Ordered list of remotes to sync git with
+	, syncGitRemotes :: [Remote]
+	-- Ordered list of remotes to sync data with
+	, syncDataRemotes :: [Remote]
 	-- Pairing request that is in progress.
 	, pairingInProgress :: Maybe PairingInProgress
 	-- Broadcasts notifications about all changes to the DaemonStatus
@@ -60,6 +64,8 @@ newDaemonStatus = DaemonStatus
 	<*> pure M.empty
 	<*> pure firstAlertId
 	<*> pure []
+	<*> pure []
+	<*> pure []
 	<*> pure Nothing
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster

Assistant/WebApp/Configurators.hs

@@ -17,7 +17,6 @@ import Assistant.WebApp.SideBar
 import Assistant.WebApp.Utility
 import Assistant.WebApp.Configurators.Local
 import Utility.Yesod
-import Assistant.NetMessager
 import qualified Remote
 import qualified Types.Remote as Remote
 import Annex.UUID (getUUID)

Assistant/WebApp/Configurators/XMPP.hs

@@ -100,7 +100,7 @@ buddyListDisplay = do
 	autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
 #ifdef WITH_XMPP
 	buddies <- lift $ liftAssistant $ do
-		rs <- filter isXMPPRemote . syncRemotes <$> getDaemonStatus
+		rs <- filter isXMPPRemote . syncGitRemotes <$> getDaemonStatus
 		let pairedwith = catMaybes $ map (parseJID . getXMPPClientID) rs
 		catMaybes . map (buddySummary pairedwith)
 			<$> (getBuddyList <<~ buddyList)

Assistant/XMPP/Git.hs

@@ -238,7 +238,7 @@ xmppRemotes cid = case baseJID <$> parseJID cid of
 	Nothing -> return []
 	Just jid -> do
 		let loc = gitXMPPLocation jid
-		filter (matching loc . Remote.repo) . syncRemotes 
+		filter (matching loc . Remote.repo) . syncGitRemotes 
 			<$> getDaemonStatus
   where
 	matching loc r = repoIsUrl r && repoLocation r == loc