diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Sync.hs | 34 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 4 | ||||
| -rw-r--r-- | Assistant/XMPP/Git.hs | 49 |
3 files changed, 49 insertions, 38 deletions
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 201e6e534..8d7ead31d 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -84,10 +84,6 @@ reconnectRemotes notifypushes rs = void $ do - fallback mode, where our push is guarenteed to succeed if the remote is - reachable. If the fallback fails, the push is queued to be retried - later. - - - - The fallback mode pushes to branches on the remote that have our uuid in - - them. While ugly, those branches are reserved for pushing by us, and - - so our pushes will succeed. -} pushToRemotes :: UTCTime -> Bool -> [Remote] -> Assistant Bool pushToRemotes now notifypushes remotes = do @@ -132,7 +128,7 @@ pushToRemotes now notifypushes remotes = do fallback branch g u rs = do debug ["fallback pushing to", show rs] (succeeded, failed) <- liftIO $ - inParallel (pushfallback g u branch) rs + inParallel (\r -> pushFallback u branch r g) rs updatemap succeeded failed when (notifypushes && (not $ null succeeded)) $ sendNetMessage $ NotifyPush $ @@ -140,20 +136,26 @@ pushToRemotes now notifypushes remotes = do return $ null failed push g branch remote = Command.Sync.pushBranch remote branch g - pushfallback g u branch remote = Git.Command.runBool "push" + +{- This fallback push mode pushes to branches on the remote that have our + - uuid in them. While ugly, those branches are reserved for pushing by us, + - and so our pushes will never conflict with other pushes. -} +pushFallback :: UUID -> Git.Ref -> Remote -> Git.Repo -> IO Bool +pushFallback u branch remote = Git.Command.runBool "push" params + where + params = [ Param $ Remote.name remote , Param $ refspec Annex.Branch.name , Param $ refspec branch - ] g - where - {- Push to refs/synced/uuid/branch; this - - avoids cluttering up the branch display. -} - refspec b = concat - [ s - , ":" - , "refs/synced/" ++ fromUUID u ++ "/" ++ s - ] - where s = show $ Git.Ref.base b + ] + {- Push to refs/synced/uuid/branch; this + - avoids cluttering up the branch display. -} + refspec b = concat + [ s + , ":" + , "refs/synced/" ++ fromUUID u ++ "/" ++ s + ] + where s = show $ Git.Ref.base b {- Manually pull from remotes and merge their branches. -} manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool) diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index d31712770..e473b5305 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -167,8 +167,8 @@ decodeMessage m = decode =<< gitAnnexTagInfo m fmap (ReceivePackDone . decodeExitCode) . readish . T.unpack . tagValue ] - pushdecoder a m i = Pushing - <$> (formatJID <$> messageFrom m) + pushdecoder a m' i = Pushing + <$> (formatJID <$> messageFrom m') <*> a i decodeExitCode :: Int -> ExitCode diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 86c9c9a9b..6aa280ec7 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -16,12 +16,12 @@ import Assistant.DaemonStatus import Assistant.Alert import Assistant.MakeRemote import Assistant.Sync +import qualified Command.Sync +import qualified Annex.Branch import Annex.UUID import Config import Git -import qualified Git.Command import qualified Git.Branch -import qualified Annex.Branch import Locations.UserConfig import qualified Types.Remote as Remote import Utility.FileMode @@ -53,9 +53,9 @@ makeXMPPGitRemote buddyname jid u = do syncNewRemote remote return True -{- Pushes the named refs to the remote, over XMPP, communicating with a - - specific client that either requested the push, or responded to our - - message. +{- Pushes over XMPP, communicating with a specific client. + - Runs an arbitrary IO action to push, which should run git-push with + - an xmpp:: url. - - To handle xmpp:: urls, git push will run git-remote-xmpp, which is - injected into its PATH, and in turn runs git-annex xmppgit. The @@ -72,8 +72,8 @@ makeXMPPGitRemote buddyname jid u = do - - We listen at the other end of the pipe and relay to and from XMPP. -} -xmppPush :: ClientID -> Remote -> [Ref] -> Assistant Bool -xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do +xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool +xmppPush cid gitpush = runPush (SendPushRunning cid) handleDeferred $ do sendNetMessage $ Pushing cid StartingPush (Fd inf, writepush) <- liftIO createPipe @@ -104,9 +104,7 @@ 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 params = Param (Remote.name remote) : map (Param . show) refs - r <- liftIO $ Git.Command.runBool "push" params $ - g { gitEnv = Just $ M.toList myenv } + r <- liftIO $ gitpush $ g { gitEnv = Just $ M.toList myenv } liftIO $ do mapM_ killThread [t1, t2] @@ -233,16 +231,27 @@ whenXMPPRemote :: ClientID -> Assistant () -> Assistant () whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid) handlePushMessage :: NetMessage -> Assistant () -handlePushMessage (Pushing cid CanPush) = whenXMPPRemote cid $ - sendNetMessage $ Pushing cid PushRequest -handlePushMessage (Pushing cid PushRequest) = do - rs <- xmppRemotes cid - current <- liftAnnex $ inRepo Git.Branch.current - --let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO - let refs = [Ref "master:refs/remotes/xmpp/newmaster"] - forM_ rs $ \r -> xmppPush cid r refs -handlePushMessage (Pushing cid StartingPush) = whenXMPPRemote cid $ - void $ xmppReceivePack cid +handlePushMessage (Pushing cid CanPush) = + whenXMPPRemote cid $ + sendNetMessage $ Pushing cid PushRequest + +handlePushMessage (Pushing cid PushRequest) = + go =<< liftAnnex (inRepo Git.Branch.current) + where + go Nothing = noop + go (Just branch) = do + rs <- xmppRemotes cid + liftAnnex $ Annex.Branch.commit "update" + (g, u) <- liftAnnex $ (,) + <$> gitRepo + <*> getUUID + liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g + debug ["pushing to", show rs] + forM_ rs $ \r -> xmppPush cid $ pushFallback u branch r + +handlePushMessage (Pushing cid StartingPush) = + whenXMPPRemote cid $ + void $ xmppReceivePack cid handlePushMessage _ = noop handleDeferred :: NetMessage -> Assistant () |