summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-09 14:34:06 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-09 14:34:06 -0400
commitdcaa93dd5aff1be6e085f689672c2ec35d5f49f1 (patch)
treece5cd2bae1b8625f5f43ec0af6d65d12db2ba5fd /Assistant
parentb8e1ac94f21661786dd1825418b9d1d512a6a878 (diff)
add canpush xmpp command
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Sync.hs18
-rw-r--r--Assistant/Threads/XMPPClient.hs8
-rw-r--r--Assistant/Types/NetMessager.hs3
-rw-r--r--Assistant/XMPP.hs9
-rw-r--r--Assistant/XMPP/Git.hs31
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