webapp: Display an alert when there are XMPP remotes, and a cloud transfer repository needs to be configured.

5 files changed, 61 insertions, 17 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 65f8c3e67..40c37a94a 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -34,6 +34,7 @@ data AlertName
 	| WarningAlert String
 	| PairAlert String
 	| XMPPNeededAlert
+	| CloudRepoNeededAlert
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.
@@ -333,6 +334,24 @@ xmppNeededAlert button = Alert
 	, alertData = []
 	}
 
+cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert
+cloudRepoNeededAlert friendname button = Alert
+	{ alertHeader = Just $ fromString $ unwords
+		[ "Unable to download files from"
+		, (fromMaybe "your other devices" friendname) ++ "."
+		]
+	, alertIcon = Just ErrorIcon
+	, alertPriority = High
+	, alertButton = Just button
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = tenseWords
+	, alertBlockDisplay = True
+	, alertName = Just $ CloudRepoNeededAlert
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
 fileAlert :: TenseChunk -> FilePath -> Alert
 fileAlert msg file = (activityAlert Nothing [f])
 	{ alertName = Just $ FileAlert msg
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index ea57176b5..fcfb1a4f3 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -51,10 +51,14 @@ calcSyncRemotes = do
 	alive <- trustExclude DeadTrusted (map Remote.uuid rs)
 	let good r = Remote.uuid r `elem` alive
 	let syncable = filter good rs
+	let nonxmpp = filter (not . isXMPPRemote) syncable
 	return $ \dstatus -> dstatus
 		{ syncRemotes = syncable
-		, syncGitRemotes = filter (not . Remote.specialRemote) syncable
-		, syncDataRemotes = filter (not . isXMPPRemote) syncable
+		, syncGitRemotes =
+			filter (not . Remote.specialRemote) syncable
+		, syncDataRemotes = nonxmpp
+		, syncingToCloudRemote =
+			any (Git.repoIsUrl . Remote.repo) nonxmpp
 		}
 
 {- Updates the sycRemotes list from the list of all remotes in Annex state. -}
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index fb7da10c7..69a886c4a 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -111,7 +111,7 @@ xmppClient urlrenderer d creds =
 	handle _ (GotNetMessage m@(Pushing _ pushstage))
 		| isPushInitiation pushstage = inAssistant $
 			unlessM (queueNetPushMessage m) $ 
-				void $ forkIO <~> handlePushInitiation m
+				void $ forkIO <~> handlePushInitiation urlrenderer m
 		| otherwise = void $ inAssistant $ queueNetPushMessage m
 	handle _ (Ignorable _) = noop
 	handle _ (Unknown _) = noop
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index df95b23c0..0fc800a37 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -46,6 +46,8 @@ data DaemonStatus = DaemonStatus
 	, syncGitRemotes :: [Remote]
 	-- Ordered list of remotes to sync data with
 	, syncDataRemotes :: [Remote]
+	-- Are we syncing to any cloud remotes?
+	, syncingToCloudRemote :: Bool
 	-- List of uuids of remotes that we may have gotten out of sync with.
 	, desynced :: S.Set UUID
 	-- Pairing request that is in progress.
@@ -81,6 +83,7 @@ newDaemonStatus = DaemonStatus
 	<*> pure []
 	<*> pure []
 	<*> pure []
+	<*> pure False
 	<*> pure S.empty
 	<*> pure Nothing
 	<*> newNotificationBroadcaster
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index a088f459e..74ce4b725 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.XMPP.Git where
 
 import Assistant.Common
@@ -29,6 +31,10 @@ import qualified Remote as Remote
 import Remote.List
 import Utility.FileMode
 import Utility.Shell
+#ifdef WITH_WEBAPP
+import Assistant.WebApp (UrlRenderer)
+import Assistant.WebApp.Configurators.XMPP
+#endif
 
 import Network.Protocol.XMPP
 import qualified Data.Text as T
@@ -80,8 +86,8 @@ makeXMPPGitRemote buddyname jid u = do
  -
  - We listen at the other end of the pipe and relay to and from XMPP.
  -}
-xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
-xmppPush cid gitpush = runPush SendPack cid handleDeferred $ do
+xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> (NetMessage -> Assistant ()) -> Assistant Bool
+xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
 	sendNetMessage $ Pushing cid StartingPush
 
 	(Fd inf, writepush) <- liftIO createPipe
@@ -201,8 +207,8 @@ xmppGitRelay = do
 
 {- Relays git receive-pack stdin and stdout via XMPP, as well as propigating
  - its exit status to XMPP. -}
-xmppReceivePack :: ClientID -> Assistant Bool
-xmppReceivePack cid = runPush ReceivePack cid handleDeferred $ do
+xmppReceivePack :: ClientID -> (NetMessage -> Assistant ()) -> Assistant Bool
+xmppReceivePack cid handledeferred = runPush ReceivePack cid handledeferred $ do
 	repodir <- liftAnnex $ fromRepo repoPath
 	let p = (proc "git" ["receive-pack", repodir])
 		{ std_in = CreatePipe
@@ -250,11 +256,11 @@ xmppRemotes cid = case baseJID <$> parseJID cid of
   where
 	matching loc r = repoIsUrl r && repoLocation r == loc
 
-handlePushInitiation :: NetMessage -> Assistant ()
-handlePushInitiation (Pushing cid CanPush) =
+handlePushInitiation :: UrlRenderer -> NetMessage -> Assistant ()
+handlePushInitiation _ (Pushing cid CanPush) =
 	unlessM (null <$> xmppRemotes cid) $ 
 		sendNetMessage $ Pushing cid PushRequest
-handlePushInitiation (Pushing cid PushRequest) =
+handlePushInitiation urlrenderer (Pushing cid PushRequest) =
 	go =<< liftAnnex (inRepo Git.Branch.current)
   where
 	go Nothing = noop
@@ -266,18 +272,30 @@ handlePushInitiation (Pushing cid PushRequest) =
 			<*> getUUID
 		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
 		selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
-		forM_ rs $ \r -> alertWhile (syncAlert [r]) $
-			xmppPush cid $ taggedPush u selfjid branch r
-handlePushInitiation (Pushing cid StartingPush) = do
+		forM_ rs $ \r -> do
+			void $ alertWhile (syncAlert [r]) $
+				xmppPush cid
+					(taggedPush u selfjid branch r)
+					(handleDeferred urlrenderer)
+			checkCloudRepos urlrenderer r
+handlePushInitiation urlrenderer (Pushing cid StartingPush) = do
 	rs <- xmppRemotes cid
-	unless (null rs) $
+	unless (null rs) $ do
 		void $ alertWhile (syncAlert rs) $
-			xmppReceivePack cid
-handlePushInitiation _ = noop
+			xmppReceivePack cid (handleDeferred urlrenderer)
+		mapM_ (checkCloudRepos urlrenderer) rs
+handlePushInitiation _ _ = noop
 
-handleDeferred :: NetMessage -> Assistant ()
+handleDeferred :: UrlRenderer -> NetMessage -> Assistant ()
 handleDeferred = handlePushInitiation
 
+checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
+-- TODO only display if needed
+checkCloudRepos urlrenderer r =
+#ifdef WITH_WEBAPP
+	cloudRepoNeeded urlrenderer (Remote.uuid r)
+#endif
+
 writeChunk :: Handle -> B.ByteString -> IO ()
 writeChunk h b = do
 	B.hPut h b