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

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

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. -}

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

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

Assistant/WebApp/Configurators/Pairing.hs

@@ -186,12 +186,6 @@ getFinishXMPPPairR _ = noXMPPPairing
 xmppPairStatus :: Bool -> Maybe JID -> Handler RepHtml
 xmppPairStatus inprogress theirjid = pairPage $ do
 	let friend = buddyName <$> theirjid
-	let cloudrepolist = repoListDisplay $ RepoSelector
-		{ onlyCloud = True
-		, onlyConfigured = False
-		, includeHere = False
-		, nudgeAddMore = False
-		}
 	$(widgetFile "configurators/pairing/xmpp/end")
 #endif
 

Assistant/WebApp/Configurators/XMPP.hs

@@ -13,6 +13,7 @@ module Assistant.WebApp.Configurators.XMPP where
 import Assistant.WebApp.Common
 import Assistant.WebApp.Notifications
 import Utility.NotificationBroadcaster
+import qualified Remote
 #ifdef WITH_XMPP
 import Assistant.XMPP.Client
 import Assistant.XMPP.Buddies
@@ -21,6 +22,9 @@ import Assistant.NetMessager
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.SRV
+import Assistant.WebApp.RepoList
+import Assistant.WebApp.Configurators
+import Assistant.XMPP
 #endif
 
 #ifdef WITH_XMPP
@@ -30,7 +34,7 @@ import qualified Data.Text as T
 import Control.Exception (SomeException)
 #endif
 
-{- Displays an alert suggesting to configure XMPP, with a button. -}
+{- Displays an alert suggesting to configure XMPP. -}
 xmppNeeded :: Handler ()
 #ifdef WITH_XMPP
 xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
@@ -46,6 +50,48 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
 xmppNeeded = return ()
 #endif
 
+{- Displays an alert suggesting to configure a cloud repo
+ - to suppliment an XMPP remote. -}
+cloudRepoNeeded :: UrlRenderer -> UUID -> Assistant ()
+#ifdef WITH_XMPP
+cloudRepoNeeded urlrenderer for = do
+	buddyname <- getBuddyName for
+	url <- liftIO $ renderUrl urlrenderer (NeedCloudRepoR for) []
+	close <- asIO1 removeAlert
+	void $ addAlert $ cloudRepoNeededAlert buddyname $ AlertButton
+		{ buttonLabel = "Add a cloud repository"
+		, buttonUrl = url
+		, buttonAction = Just close
+		}
+#else
+cloudRepoNeeded = return ()
+#endif
+
+{- Returns the name of the friend corresponding to a
+ - repository's UUID, but not if it's our name. -}
+getBuddyName :: UUID -> Assistant (Maybe String)
+getBuddyName u = go =<< getclientjid
+  where
+	go Nothing = return Nothing
+	go (Just myjid) = (T.unpack . buddyName <$>)
+		. headMaybe 
+		. filter (\j -> baseJID j /= baseJID myjid)
+		. map fst
+		. filter (\(_, r) -> Remote.uuid r == u)
+		<$> getXMPPRemotes
+	getclientjid = maybe Nothing parseJID . xmppClientID
+		<$> getDaemonStatus
+
+getNeedCloudRepoR :: UUID -> Handler RepHtml
+#ifdef WITH_XMPP
+getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
+	buddyname <- lift $ liftAssistant $ getBuddyName for
+	$(widgetFile "configurators/xmpp/needcloudrepo")
+#else
+needCloudRepoR = xmppPage $
+	$(widgetFile "configurators/xmpp/disabled")
+#endif
+
 getXMPPR :: Handler RepHtml
 #ifdef WITH_XMPP
 getXMPPR = xmppPage $ do
@@ -86,8 +132,7 @@ buddyListDisplay = do
 	myjid <- lift $ liftAssistant $ xmppClientID <$> getDaemonStatus
 	let isself (BuddyKey b) = Just b == myjid
 	buddies <- lift $ liftAssistant $ do
-		rs <- filter isXMPPRemote . syncGitRemotes <$> getDaemonStatus
-		let pairedwith = catMaybes $ map (parseJID . getXMPPClientID) rs
+		pairedwith <- map fst <$> getXMPPRemotes
 		catMaybes . map (buddySummary pairedwith)
 			<$> (getBuddyList <<~ buddyList)
 	$(widgetFile "configurators/xmpp/buddylist")
@@ -97,6 +142,13 @@ buddyListDisplay = do
 
 #ifdef WITH_XMPP
 
+getXMPPRemotes :: Assistant [(JID, Remote)]
+getXMPPRemotes = catMaybes . map pair . filter isXMPPRemote . syncGitRemotes
+	<$> getDaemonStatus
+  where
+  	pair r = maybe Nothing (\jid -> Just (jid, r)) $
+		parseJID $ getXMPPClientID r
+
 data XMPPForm = XMPPForm
 	{ formJID :: Text
 	, formPassword :: Text }

Assistant/WebApp/RepoList.hs

@@ -81,6 +81,15 @@ mainRepoSelector = RepoSelector
 	, nudgeAddMore = False
 	}
 
+{- List of cloud repositories, configured and not. -}
+cloudRepoList :: Widget
+cloudRepoList = repoListDisplay $ RepoSelector
+	{ onlyCloud = True
+	, onlyConfigured = False
+	, includeHere = False
+	, nudgeAddMore = False
+	}
+
 repoListDisplay :: RepoSelector -> Widget
 repoListDisplay reposelector = do
 	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)

Assistant/WebApp/routes

@@ -16,6 +16,7 @@
 /config ConfigurationR GET
 /config/preferences PreferencesR GET
 /config/xmpp XMPPR GET
+/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new/first FirstRepositoryR GET

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

debian/changelog

@@ -3,6 +3,8 @@ git-annex (4.20130315) UNRELEASED; urgency=low
   * webapp: Repository list is now included in the dashboard, and other
     UI tweaks.
   * webapp: Improved UI for pairing your own devices together using XMPP.
+  * webapp: Display an alert when there are XMPP remotes, and a cloud
+    transfer repository needs to be configured.
 
  -- Joey Hess <joeyh@debian.org>  Fri, 15 Mar 2013 00:10:07 -0400
 

templates/configurators/pairing/xmpp/end.hamlet

@@ -26,7 +26,7 @@
       Make sure that your other devices are configured to access a #
       cloud repository, and that the same repository is enabled here #
       too.
-  ^{cloudrepolist}
+  ^{cloudRepoList}
   <h2>
     Add a cloud repository
   ^{makeCloudRepositories True}

templates/configurators/xmpp/needcloudrepo.hamlet

@@ -0,0 +1,17 @@
+<div .span9 .hero-unit>
+  <h2>
+    &#9730; Configure a shared cloud repository
+  $maybe name <- buddyname
+    <p>
+      You and #{name} have combined your repositores. But you can't open #
+      each other's files yet. To start sharing files with #{name}, #
+      you need a repository in the cloud, that you both can access.
+  $nothing
+    <p>
+      You've combined the repositories on two or more of your devices. #
+      But files are not flowing yet. To start sharing files #
+      between your devices, you should set up a repository in the cloud.
+  ^{cloudRepoList}
+  <h2>
+    Add a cloud repository
+  ^{makeCloudRepositories True}