summaryrefslogtreecommitdiff
path: root/Assistant/XMPP/Git.hs
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/XMPP/Git.hs
parentb8e1ac94f21661786dd1825418b9d1d512a6a878 (diff)
add canpush xmpp command
Diffstat (limited to 'Assistant/XMPP/Git.hs')
-rw-r--r--Assistant/XMPP/Git.hs31
1 files changed, 16 insertions, 15 deletions
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