mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

refactor

Browse source
This commit is contained in:
Joey Hess 2012-11-09 23:43:08 -04:00
parent c00ecfbb83
commit ee0958e044
1 changed files with 14 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
Assistant/XMPP/Git.hs
View file

@ -42,14 +42,16 @@ finishXMPPPairing jid u = void $ alertWhile alert $
buddy = T.unpack $ buddyName jid buddy = T.unpack $ buddyName jid
alert = pairRequestAcknowledgedAlert buddy Nothing alert = pairRequestAcknowledgedAlert buddy Nothing
gitXMPPLocation :: JID -> String
gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
makeXMPPGitRemote buddyname jid u = do 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 liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u
syncNewRemote remote syncNewRemote remote
return True return True
where
xmppaddress = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
{- Pushes the named refs to the remote, over XMPP, communicating with a {- Pushes the named refs to the remote, over XMPP, communicating with a
- specific client that either requested the push, or responded to our - 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 {- This can take a long time to run, so avoid running it in the
- Annex monad. Also, override environment. -} - Annex monad. Also, override environment. -}
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
let g' = g { gitEnv = Just $ M.toList myenv } let params = Param (Remote.name remote) : map (Param . show) refs
let name = Remote.name remote r <- liftIO $ Git.Command.runBool "push" params $
let params = Param name : map (Param . show) refs g { gitEnv = Just $ M.toList myenv }
ok <- liftIO $ Git.Command.runBool "push" params g'
liftIO $ do liftIO $ do
mapM_ killThread [t1, t2] mapM_ killThread [t1, t2]
mapM_ hClose [inh, outh, controlh] mapM_ hClose [inh, outh, controlh]
return ok return r
where where
toxmpp inh = forever $ do toxmpp inh = forever $ do
b <- liftIO $ B.hGetSome inh chunkSize b <- liftIO $ B.hGetSome inh chunkSize
@ -229,13 +230,11 @@ xmppRemotes :: ClientID -> Assistant [Remote]
xmppRemotes cid = case baseJID <$> parseJID cid of xmppRemotes cid = case baseJID <$> parseJID cid of
Nothing -> return [] Nothing -> return []
Just jid -> do Just jid -> do
rs <- syncRemotes <$> getDaemonStatus let loc = gitXMPPLocation jid
let want = T.unpack $ formatJID jid filter (matching loc . Remote.repo) . syncRemotes
liftAnnex $ filterM (matching want) rs <$> getDaemonStatus
where where
matching want remote = do matching loc r = repoIsUrl r && repoLocation r == loc
let r = Remote.repo remote
return $ repoIsUrl r && repoLocation r == "xmpp::" ++ want
whenXMPPRemote :: ClientID -> Assistant () -> Assistant () whenXMPPRemote :: ClientID -> Assistant () -> Assistant ()
whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid) whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid)
@ -247,7 +246,7 @@ handlePushMessage (PushRequest cid) = do
rs <- xmppRemotes cid rs <- xmppRemotes cid
current <- liftAnnex $ inRepo Git.Branch.current current <- liftAnnex $ inRepo Git.Branch.current
--let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO --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 forM_ rs $ \r -> xmppPush cid r refs
handlePushMessage (StartingPush cid) = whenXMPPRemote cid $ handlePushMessage (StartingPush cid) = whenXMPPRemote cid $
void $ xmppReceivePack cid void $ xmppReceivePack cid