full-on git-annex assistant syncing now works over XMPP!
I decided to use the fallback push mode from the beginning for XMPP, since while it uses some ugly branches, it avoids the possibility of a normal push failing, and needing to pull and re-push. Due to the overhead of XMPP, and the difficulty of building such a chain of actions due to the async implementation, this seemed reasonable. It seems to work great!
This commit is contained in:
parent
2a88845c28
commit
957e742dfc
3 changed files with 49 additions and 38 deletions
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue