summaryrefslogtreecommitdiff
path: root/Assistant/XMPP
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-09 23:43:08 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-09 23:52:51 -0400
commitde9f2fa14a82cf1ef7359e8b7ccea4c14c3b8f89 (patch)
tree80b3ba6b8dd75361e59c1d3788f1b0e4e6cb760b /Assistant/XMPP
parentdfa3da4efa401d0373d8e7062eb9045b9c54c474 (diff)
refactor
Diffstat (limited to 'Assistant/XMPP')
-rw-r--r--Assistant/XMPP/Git.hs29
1 files changed, 14 insertions, 15 deletions
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 0ff6f3ed1..b2d645fad 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -42,14 +42,16 @@ finishXMPPPairing jid u = void $ alertWhile alert $
buddy = T.unpack $ buddyName jid
alert = pairRequestAcknowledgedAlert buddy Nothing
+gitXMPPLocation :: JID -> String
+gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
+
makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
makeXMPPGitRemote buddyname jid u = do
- remote <- liftAnnex $ addRemote $ makeGitRemote buddyname xmppaddress
+ remote <- liftAnnex $ addRemote $
+ makeGitRemote buddyname $ gitXMPPLocation jid
liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u
syncNewRemote remote
return True
- where
- xmppaddress = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
{- Pushes the named refs to the remote, over XMPP, communicating with a
- specific client that either requested the push, or responded to our
@@ -104,16 +106,15 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
{- This can take a long time to run, so avoid running it in the
- Annex monad. Also, override environment. -}
g <- liftAnnex gitRepo
- let g' = g { gitEnv = Just $ M.toList myenv }
- let name = Remote.name remote
- let params = Param name : map (Param . show) refs
- ok <- liftIO $ Git.Command.runBool "push" params g'
+ let params = Param (Remote.name remote) : map (Param . show) refs
+ r <- liftIO $ Git.Command.runBool "push" params $
+ g { gitEnv = Just $ M.toList myenv }
liftIO $ do
mapM_ killThread [t1, t2]
mapM_ hClose [inh, outh, controlh]
- return ok
+ return r
where
toxmpp inh = forever $ do
b <- liftIO $ B.hGetSome inh chunkSize
@@ -229,13 +230,11 @@ xmppRemotes :: ClientID -> Assistant [Remote]
xmppRemotes cid = case baseJID <$> parseJID cid of
Nothing -> return []
Just jid -> do
- rs <- syncRemotes <$> getDaemonStatus
- let want = T.unpack $ formatJID jid
- liftAnnex $ filterM (matching want) rs
+ let loc = gitXMPPLocation jid
+ filter (matching loc . Remote.repo) . syncRemotes
+ <$> getDaemonStatus
where
- matching want remote = do
- let r = Remote.repo remote
- return $ repoIsUrl r && repoLocation r == "xmpp::" ++ want
+ matching loc r = repoIsUrl r && repoLocation r == loc
whenXMPPRemote :: ClientID -> Assistant () -> Assistant ()
whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid)
@@ -247,7 +246,7 @@ handlePushMessage (PushRequest cid) = do
rs <- xmppRemotes cid
current <- liftAnnex $ inRepo Git.Branch.current
--let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO
- let refs = [Ref "master:refs/xmpp/newmaster"]
+ let refs = [Ref "master:refs/remotes/xmpp/newmaster"]
forM_ rs $ \r -> xmppPush cid r refs
handlePushMessage (StartingPush cid) = whenXMPPRemote cid $
void $ xmppReceivePack cid