add canpush xmpp command

5 files changed, 50 insertions, 19 deletions

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 9eaad5469..97fcc88ce 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -27,6 +27,7 @@ import Annex.UUID
 
 import Data.Time.Clock
 import qualified Data.Map as M
+import qualified Data.Text as T
 import Control.Concurrent
 
 {- Syncs with remotes that may have been disconnected for a while.
@@ -66,7 +67,8 @@ reconnectRemotes notifypushes rs = void $ do
  - as "git annex sync", except in parallel, and will co-exist with use of
  - "git annex sync".
  -
- - After the pushes to normal git remotes, also handles pushes over XMPP.
+ - After the pushes to normal git remotes, also signals XMPP clients that
+ - they can request an XMPP push.
  -
  - Avoids running possibly long-duration commands in the Annex monad, so
  - as not to block other threads.
@@ -95,7 +97,10 @@ pushToRemotes now notifypushes remotes = do
 			<$> gitRepo
 			<*> inRepo Git.Branch.current
 			<*> getUUID
-	go True branch g u remotes
+	let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
+	r <- go True branch g u normalremotes
+	mapM_ (sendNetMessage . CanPush . getXMPPClientID) xmppremotes
+	return r
   where
 	go _ Nothing _ _ _ = return True -- no branch, so nothing to do
 	go shouldretry (Just branch) g u rs =  do
@@ -167,3 +172,12 @@ syncNewRemote remote = do
 	thread <- asIO $ do
 		reconnectRemotes False [remote]
 	void $ liftIO $ forkIO $ thread
+
+{- 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))
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index efdecb587..32353fdc4 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -96,10 +96,12 @@ xmppClient urlrenderer d = do
 	handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
 	handle selfjid (GotNetMessage (PairingNotification stage c u)) =
 		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
+	handle _ (GotNetMessage m@(CanPush _)) = inAssistant $ 
+		unlessM (queueNetPushMessage m) $ void $ handlePushMessage m
 	handle _ (GotNetMessage m@(PushRequest _)) = inAssistant $ 
-		unlessM (queueNetPushMessage m) $ void $ handlePush m
+		unlessM (queueNetPushMessage m) $ void $ handlePushMessage m
 	handle _ (GotNetMessage m@(StartingPush _)) = inAssistant $
-		unlessM (queueNetPushMessage m) $ void $ handlePush m
+		unlessM (queueNetPushMessage m) $ void $ handlePushMessage m
 	handle _ (GotNetMessage m) = void $ inAssistant $ queueNetPushMessage m
 	handle _ (Ignorable _) = noop
 	handle _ (Unknown _) = noop
@@ -137,6 +139,7 @@ decodeStanza selfjid s@(ReceivedMessage m)
   where
 	decode (attr, v, tag)
 		| attr == pairAttr = use $ decodePairingNotification v
+		| attr == canPushAttr = use decodeCanPush
 		| attr == pushRequestAttr = use decodePushRequest
 		| attr == startingPushAttr = use decodeStartingPush
 		| attr == receivePackAttr = use $ decodeReceivePackOutput tag
@@ -155,6 +158,7 @@ relayNetMessage selfjid = convert =<< waitNetMessage
 	convert (PairingNotification stage c u) = withclient c $ \tojid -> do
 		changeBuddyPairing tojid True
 		return $ putStanza $ pairingNotification stage u tojid selfjid
+	convert (CanPush c) = sendclient c canPush
 	convert (PushRequest c) = sendclient c pushRequest
 	convert (StartingPush c) = sendclient c startingPush
 	convert (ReceivePackOutput c b) = sendclient c $ receivePackOutput b
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index 6974cf57d..3d7bb4d04 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -25,6 +25,8 @@ data NetMessage
 	-- notification about a stage in the pairing process,
 	-- involving a client, and a UUID.
 	| PairingNotification PairStage ClientID UUID
+	-- indicates that we have data to push over the out of band network
+	| CanPush ClientID
 	-- request that a git push be sent over the out of band network
 	| PushRequest ClientID
 	-- indicates that a push is starting
@@ -44,6 +46,7 @@ getClientID :: NetMessage -> Maybe ClientID
 getClientID (NotifyPush _) = Nothing
 getClientID QueryPresence = Nothing
 getClientID (PairingNotification _ cid _) = Just cid
+getClientID (CanPush cid) = Just cid
 getClientID (PushRequest cid) = Just cid
 getClientID (StartingPush cid) = Just cid
 getClientID (ReceivePackOutput cid _) = Just cid
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 104915b81..68da087a6 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -130,6 +130,15 @@ decodePairingNotification t m = parse $ words $ T.unpack t
 		<*> pure (toUUID u)
 	parse _ = Nothing
 
+canPush :: JID -> JID -> Message
+canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
+
+decodeCanPush :: Message -> Maybe NetMessage
+decodeCanPush m = CanPush <$> (formatJID <$> messageFrom m)
+
+canPushAttr :: Name
+canPushAttr = "canpush"
+
 pushRequest :: JID -> JID -> Message
 pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
 
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 624791597..49adadcfd 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -34,9 +34,6 @@ import System.Process (std_in, std_out, std_err)
 import Control.Concurrent
 import qualified Data.ByteString as B
 
-configKey :: UnqualifiedConfigKey
-configKey = "xmppaddress"
-
 finishXMPPPairing :: JID -> UUID -> Assistant ()
 finishXMPPPairing jid u = void $ alertWhile alert $
 	makeXMPPGitRemote buddy (baseJID jid) u
@@ -47,10 +44,7 @@ finishXMPPPairing jid u = void $ alertWhile alert $
 makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
 makeXMPPGitRemote buddyname jid u = do
 	remote <- liftAnnex $ addRemote $ makeGitRemote buddyname xmppaddress
-	liftAnnex $ do
-		let r = Remote.repo remote
-		storeUUID (remoteConfig r "uuid") u
-		setConfig (remoteConfig r configKey) xmppaddress
+	liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u
 	syncNewRemote remote
 	return True
   where
@@ -221,22 +215,29 @@ xmppRemotes cid = case baseJID <$> parseJID cid of
 		let want = T.unpack $ formatJID jid
 		liftAnnex $ filterM (matching want) rs
   where
-	matching want r = do
-		v <- getRemoteConfig (Remote.repo r) configKey ""
-		return $ v == want
+	matching want remote = do
+		let r = Remote.repo remote
+		return $ repoIsUrl r && repoLocation r == "xmpp::" ++ want
 
 handleDeferred :: NetMessage -> Assistant ()
-handleDeferred = void . handlePush
+handleDeferred = void . handlePushMessage
 
-handlePush :: NetMessage -> Assistant Bool
-handlePush (PushRequest cid) = do
+handlePushMessage :: NetMessage -> Assistant Bool
+handlePushMessage (CanPush cid) = do
+	rs <- xmppRemotes cid
+	if null rs
+		then return False
+		else do
+			sendNetMessage $ PushRequest cid
+			return True
+handlePushMessage (PushRequest cid) = do
 	rs <- xmppRemotes cid
 	current <- liftAnnex $ inRepo Git.Branch.current
 	let refs = catMaybes [current, Just Annex.Branch.fullname]
 	any id <$> (forM rs $ \r -> xmppPush cid r refs)
-handlePush (StartingPush cid) = do
+handlePushMessage (StartingPush cid) = do
 	rs <- xmppRemotes cid
 	if null rs
 		then return False
 		else xmppReceivePack cid
-handlePush _ = return False
+handlePushMessage _ = return False