end of xmpp pairing page encourages adding a shared cloud repository

Assistant/WebApp/Configurators.hs

@@ -17,12 +17,14 @@ 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)
 import Logs.Remote
 import Logs.Trust
 import Config
+import qualified Git
 #ifdef WITH_XMPP
 import Assistant.XMPP.Client
 #endif
@@ -50,7 +52,7 @@ getConfigR = ifM (inFirstRun)
 introDisplay :: Text -> Widget
 introDisplay ident = do
 	webapp <- lift getYesod
-	repolist <- lift $ repoList True False
+	repolist <- lift $ repoList False True False
 	let n = length repolist
 	let numrepos = show n
 	$(widgetFile "configurators/intro")
@@ -62,16 +64,12 @@ makeMiscRepositories = $(widgetFile "configurators/repositories/misc")
 makeCloudRepositories :: Widget
 makeCloudRepositories = $(widgetFile "configurators/repositories/cloud")
 
-repoTable :: Widget
-repoTable = do
-	repolist <- lift $ repoList False True
-	$(widgetFile "configurators/repositories/table")
-
 {- Lists known repositories, followed by options to add more. -}
 getRepositoriesR :: Handler RepHtml
 getRepositoriesR = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Repositories"
+	repolist <- lift $ repoList False False True
 	$(widgetFile "configurators/repositories")
 
 data Actions
@@ -106,15 +104,20 @@ notSyncing :: Actions -> Bool
 notSyncing (SyncingRepoActions _ _) = False
 notSyncing _ = True
 
+repoTable :: RepoList -> Widget
+repoTable repolist = $(widgetFile "configurators/repositories/table")
+
+type RepoList = [(String, String, Actions)]
+
 {- A numbered list of known repositories,
  - with actions that can be taken on them. -}
-repoList :: Bool -> Bool -> Handler [(String, String, Actions)]
-repoList onlyconfigured includehere
+repoList :: Bool -> Bool -> Bool -> Handler RepoList
+repoList onlycloud onlyconfigured includehere
 	| onlyconfigured = list =<< configured
 	| otherwise = list =<< (++) <$> configured <*> rest
   where
 	configured = do
-		rs <- filter (not . Remote.readonly) . syncRemotes
+		rs <- filter wantedrepo . syncRemotes
 			<$> liftAssistant getDaemonStatus
 		runAnnex [] $ do
 			u <- getUUID
@@ -123,22 +126,32 @@ repoList onlyconfigured includehere
 			return $ zip l' $ map mkSyncingRepoActions l'
 	rest = runAnnex [] $ do
 		m <- readRemoteLog
-		unconfigured <- catMaybes . map (findtype m) . snd
+		unconfigured <- map snd . catMaybes . filter wantedremote 
+			. map (findinfo m) . snd
 			<$> (trustPartition DeadTrusted $ M.keys m)
-		unsyncable <- map Remote.uuid <$>
+		unsyncable <- map Remote.uuid . filter wantedrepo <$>
 			(filterM (\r -> not <$> repoSyncable (Remote.repo r))
 				=<< Remote.enabledRemoteList)
 		return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
-	findtype m u = case M.lookup u m of
+	wantedrepo r
+		| Remote.readonly r = False
+		| onlycloud = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)
+		| otherwise = True
+	wantedremote Nothing = False
+	wantedremote (Just (iscloud, _))
+		| onlycloud = iscloud
+		| otherwise = True
+	findinfo m u = case M.lookup u m of
 		Nothing -> Nothing
 		Just c -> case M.lookup "type" c of
-			Just "rsync" -> u `enableswith` EnableRsyncR
-			Just "directory" -> u `enableswith` EnableDirectoryR
+			Just "rsync" -> val True EnableRsyncR
+			Just "directory" -> val False EnableDirectoryR
 #ifdef WITH_S3
-			Just "S3" -> u `enableswith` EnableS3R
+			Just "S3" -> val True EnableS3R
 #endif
 			_ -> Nothing
-	u `enableswith` r = Just (u, DisabledRepoActions $ r u)
+	  where
+		val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
 	list l = runAnnex [] $ do
 		let l' = nubBy (\x y -> fst x == fst y) l
 		zip3

Assistant/WebApp/Configurators/Pairing.hs

@@ -12,6 +12,7 @@ module Assistant.WebApp.Configurators.Pairing where
 
 import Assistant.Pairing
 import Assistant.WebApp
+import Assistant.WebApp.Configurators
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Assistant.WebApp.Configurators.XMPP
@@ -89,14 +90,11 @@ getStartXMPPPairR bid = do
 		creds <- runAnnex Nothing getXMPPCreds
 		let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
 		let samejid = baseJID ourjid == baseJID exemplar
-		let account = formatJID $ baseJID exemplar
 		liftAssistant $ do
 			u <- liftAnnex getUUID
 			forM_ clients $ \(Client c) -> sendNetMessage $
 				PairingNotification PairReq (formatJID c) u
-		pairPage $ do
-			let name = buddyName exemplar
-			$(widgetFile "configurators/pairing/xmpp/inprogress")
+		xmppPairEnd True $ if samejid then Nothing else Just exemplar
 	-- A buddy could have logged out, or the XMPP client restarted,
 	-- and there be no clients to message; handle unforseen by going back.
 	go _ = redirect StartPairR
@@ -148,11 +146,19 @@ getFinishXMPPPairR (PairKey theiruuid t) = case parseJID t of
 			sendNetMessage $
 				PairingNotification PairAck (formatJID theirjid) selfuuid
 			finishXMPPPairing theirjid theiruuid
-		redirect RepositoriesR
+		xmppPairEnd False $ Just theirjid
 #else
 getFinishXMPPPairR _ _ = noXMPPPairing
 #endif
 
+#ifdef WITH_XMPP
+xmppPairEnd :: Bool -> Maybe JID -> Handler RepHtml
+xmppPairEnd inprogress theirjid = pairPage $ do
+	let friend = buddyName <$> theirjid
+	cloudrepolist <- lift $ repoList True False False
+	$(widgetFile "configurators/pairing/xmpp/end")
+#endif
+
 getRunningLocalPairR :: SecretReminder -> Handler RepHtml
 #ifdef WITH_PAIRING
 getRunningLocalPairR s = pairPage $ do

templates/configurators/pairing/xmpp/end.hamlet

@@ -0,0 +1,44 @@
+<div .span9 .hero-unit>
+  $if inprogress
+    <h2>
+      Pairing in progress ...
+    <p>
+      $maybe name <- friend
+        A pair request has been sent to #{name}. It's up to them #
+        to accept it and finish pairing.
+      $nothing
+        A pair request has been sent to all other devices using your jabber #
+        account.
+ <h2>
+   Configure a shared cloud repository
+  $maybe name <- friend
+    <p>
+      &#9730; To share files with #{name}, you'll need a repository in #
+      the cloud, that you both can access.
+    $if null cloudrepolist
+      <hr>
+      ^{makeCloudRepositories}
+    $else
+      <p>
+        Make sure that #{name} has access to one of these cloud repositories, #
+        and that the repository is enabled.
+      ^{repoTable cloudrepolist}
+      <hr>
+        Or, add a new cloud repository:
+        ^{makeCloudRepositories}
+  $nothing
+    <p>
+      &#9730; To share files with your other devices, when they're not #
+      nearby, you'll need a repository in the cloud.
+    $if null cloudrepolist
+      <hr>
+      ^{makeCloudRepositories}
+    $else
+      <p>
+        Make sure that your other devices are configured to access one of #
+        these cloud repositories, and that the repository is enabled here #
+        too.
+      ^{repoTable cloudrepolist}
+      <hr>
+        Or, add a new cloud repository:
+        ^{makeCloudRepositories}

templates/configurators/pairing/xmpp/inprogress.hamlet

@@ -1,19 +0,0 @@
-<div .span9 .hero-unit>
-  <h2>
-    Pairing in progress ..
-    $if samejid
-      <p>
-        A pair request has been sent to all other clients using your jabber #
-        account, #{account}.
-      <p>
-        You do not need to leave this page open; pairing will finish #
-        automatically once the other clients see the pair request.
-    $else
-      <p>
-        A pair request has been sent to #{name}.
-      <p>
-        You do not need to leave this page open; pairing will finish #
-        automatically once #{name} accepts the pair request.
-    <p>
-      <a .btn .btn-primary .btn-small href="">
-        Re-Send pair request

templates/configurators/repositories.hamlet

@@ -1,7 +1,7 @@
 <div .span9>
   <h2>
     Your repositories
-  ^{repoTable}
+  ^{repoTable repolist}
   <div .row-fluid>
     <div .span6>
       <h2>

templates/configurators/repositories/cloud.hamlet

@@ -25,4 +25,4 @@
     <i .icon-plus-sign></i> Remote server
 <p>
   Set up a repository on a remote server using #
-  <tt>ssh</tt>, to build your own personal cloud.
+  <tt>ssh</tt>.