From 13547aa6596c5f774a3781ab0a8bcaf44179575e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Nov 2012 14:34:06 -0400 Subject: [PATCH] add canpush xmpp command --- Assistant/Sync.hs | 18 ++++++++++++++++-- Assistant/Threads/XMPPClient.hs | 8 ++++++-- Assistant/Types/NetMessager.hs | 3 +++ Assistant/XMPP.hs | 9 +++++++++ Assistant/XMPP/Git.hs | 31 ++++++++++++++++--------------- doc/design/assistant/xmpp.mdwn | 11 ++++++++--- 6 files changed, 58 insertions(+), 22 deletions(-) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 9eaad54694..97fcc88ce6 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 efdecb5870..32353fdc4b 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 6974cf57df..3d7bb4d048 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 104915b81e..68da087a6f 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 6247915974..49adadcfd8 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 diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index b39d155e14..9ab8eabe62 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -56,13 +56,18 @@ For pairing, a chat message is sent, containing: ### git push over XMPP +To indicate that we could push over XMPP, a chat message is sent, +to the accounts associated with known XMPP remotes. + + + To request that a remote push to us, a chat message can be sent. -The push request is typically sent directed at the account associated -with the remote, not to a specific client. So it can result in multiple -responses. +When replying to an xmpppush message, this is directed at the specific +client that indicated it could push. But it can also be sent to +the account associated with an XMPP remote to solicit pushes from all clients. When a peer is ready to send a git push, it sends: