diff options
| -rw-r--r-- | Assistant/Sync.hs | 18 | ||||
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 8 | ||||
| -rw-r--r-- | Assistant/Types/NetMessager.hs | 3 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 9 | ||||
| -rw-r--r-- | Assistant/XMPP/Git.hs | 31 | ||||
| -rw-r--r-- | doc/design/assistant/xmpp.mdwn | 11 |
6 files changed, 58 insertions, 22 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 diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index b39d155e1..9ab8eabe6 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. + + <git-annex xmlns='git-annex' canpush="" /> + To request that a remote push to us, a chat message can be sent. <git-annex xmlns='git-annex' pushrequest="uuid" /> -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: |