summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Sync.hs5
-rw-r--r--Assistant/Types/NetMessager.hs22
-rw-r--r--Assistant/XMPP.hs22
-rw-r--r--Assistant/XMPP/Git.hs27
4 files changed, 43 insertions, 33 deletions
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 727749c4f..1b9de1656 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -113,7 +113,7 @@ pushToRemotes' now notifypushes remotes = do
let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
ret <- go True branch g u normalremotes
forM_ xmppremotes $ \r ->
- sendNetMessage $ Pushing (getXMPPClientID r) CanPush
+ sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u)
return ret
where
go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
@@ -202,8 +202,9 @@ manualPull currentbranch remotes = do
haddiverged <- liftAnnex Annex.Branch.forceUpdate
forM_ normalremotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r currentbranch
+ u <- liftAnnex getUUID
forM_ xmppremotes $ \r ->
- sendNetMessage $ Pushing (getXMPPClientID r) PushRequest
+ sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
return (catMaybes failed, haddiverged)
{- Start syncing a remote, using a background thread. -}
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index e0dcbbb56..09a558033 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -37,11 +37,11 @@ type ClientID = Text
data PushStage
-- indicates that we have data to push over the out of band network
- = CanPush
+ = CanPush UUID
-- request that a git push be sent over the out of band network
- | PushRequest
+ | PushRequest UUID
-- indicates that a push is starting
- | StartingPush
+ | StartingPush UUID
-- a chunk of output of git receive-pack
| ReceivePackOutput SequenceNum ByteString
-- a chuck of output of git send-pack
@@ -58,8 +58,8 @@ type SequenceNum = Int
{- NetMessages that are important (and small), and should be stored to be
- resent when new clients are seen. -}
isImportantNetMessage :: NetMessage -> Maybe ClientID
-isImportantNetMessage (Pushing c CanPush) = Just c
-isImportantNetMessage (Pushing c PushRequest) = Just c
+isImportantNetMessage (Pushing c (CanPush _)) = Just c
+isImportantNetMessage (Pushing c (PushRequest _)) = Just c
isImportantNetMessage _ = Nothing
readdressNetMessage :: NetMessage -> ClientID -> NetMessage
@@ -85,18 +85,18 @@ logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
{- Things that initiate either side of a push, but do not actually send data. -}
isPushInitiation :: PushStage -> Bool
-isPushInitiation CanPush = True
-isPushInitiation PushRequest = True
-isPushInitiation StartingPush = True
+isPushInitiation (CanPush _) = True
+isPushInitiation (PushRequest _) = True
+isPushInitiation (StartingPush _) = True
isPushInitiation _ = False
data PushSide = SendPack | ReceivePack
deriving (Eq, Ord)
pushDestinationSide :: PushStage -> PushSide
-pushDestinationSide CanPush = ReceivePack
-pushDestinationSide PushRequest = SendPack
-pushDestinationSide StartingPush = ReceivePack
+pushDestinationSide (CanPush _) = ReceivePack
+pushDestinationSide (PushRequest _) = SendPack
+pushDestinationSide (StartingPush _) = ReceivePack
pushDestinationSide (ReceivePackOutput _ _) = SendPack
pushDestinationSide (SendPackOutput _ _) = ReceivePack
pushDestinationSide (ReceivePackDone _) = SendPack
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 9654fdb4b..fbc351931 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -131,9 +131,12 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
pushMessage :: PushStage -> JID -> JID -> Message
pushMessage = gitAnnexMessage . encode
where
- encode CanPush = gitAnnexTag canPushAttr T.empty
- encode PushRequest = gitAnnexTag pushRequestAttr T.empty
- encode StartingPush = gitAnnexTag startingPushAttr T.empty
+ encode (CanPush u) =
+ gitAnnexTag canPushAttr $ T.pack $ fromUUID u
+ encode (PushRequest u) =
+ gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
+ encode (StartingPush u) =
+ gitAnnexTag startingPushAttr $ T.pack $ fromUUID u
encode (ReceivePackOutput n b) =
gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b
encode (SendPackOutput n b) =
@@ -157,11 +160,11 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
, receivePackDoneAttr
]
[ decodePairingNotification
- , pushdecoder $ const $ Just CanPush
- , pushdecoder $ const $ Just PushRequest
- , pushdecoder $ const $ Just StartingPush
- , pushdecoder $ gen ReceivePackOutput
- , pushdecoder $ gen SendPackOutput
+ , pushdecoder $ gen CanPush
+ , pushdecoder $ gen PushRequest
+ , pushdecoder $ gen StartingPush
+ , pushdecoder $ seqgen ReceivePackOutput
+ , pushdecoder $ seqgen SendPackOutput
, pushdecoder $
fmap (ReceivePackDone . decodeExitCode) . readish .
T.unpack . tagValue
@@ -169,7 +172,8 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
pushdecoder a m' i = Pushing
<$> (formatJID <$> messageFrom m')
<*> a i
- gen c i = do
+ gen c = Just . c . toUUID . T.unpack . tagValue
+ seqgen c i = do
packet <- decodeTagContent $ tagElement i
let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
return $ c seqnum packet
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 46c8cb173..c1605bee2 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -21,6 +21,7 @@ import Assistant.Sync
import qualified Command.Sync
import qualified Annex.Branch
import Annex.UUID
+import Logs.UUID
import Annex.TaggedPush
import Config
import Git
@@ -84,7 +85,8 @@ makeXMPPGitRemote buddyname jid u = do
-}
xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> (NetMessage -> Assistant ()) -> Assistant Bool
xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
- sendNetMessage $ Pushing cid StartingPush
+ u <- liftAnnex getUUID
+ sendNetMessage $ Pushing cid (StartingPush u)
(Fd inf, writepush) <- liftIO createPipe
(readpush, Fd outf) <- liftIO createPipe
@@ -247,26 +249,29 @@ xmppReceivePack cid handledeferred = runPush ReceivePack cid handledeferred $ do
hClose inh
killThread =<< myThreadId
-xmppRemotes :: ClientID -> Assistant [Remote]
-xmppRemotes cid = case baseJID <$> parseJID cid of
+xmppRemotes :: ClientID -> UUID -> Assistant [Remote]
+xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
Nothing -> return []
Just jid -> do
let loc = gitXMPPLocation jid
- filter (matching loc . Remote.repo) . syncGitRemotes
+ um <- liftAnnex uuidMap
+ filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes
<$> getDaemonStatus
where
matching loc r = repoIsUrl r && repoLocation r == loc
+ knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um
handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant ()
-handlePushInitiation _ (Pushing cid CanPush) =
- unlessM (null <$> xmppRemotes cid) $
- sendNetMessage $ Pushing cid PushRequest
-handlePushInitiation checkcloudrepos (Pushing cid PushRequest) =
+handlePushInitiation _ (Pushing cid (CanPush theiruuid)) =
+ unlessM (null <$> xmppRemotes cid theiruuid) $ do
+ u <- liftAnnex getUUID
+ sendNetMessage $ Pushing cid (PushRequest u)
+handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
go =<< liftAnnex (inRepo Git.Branch.current)
where
go Nothing = noop
go (Just branch) = do
- rs <- xmppRemotes cid
+ rs <- xmppRemotes cid theiruuid
liftAnnex $ Annex.Branch.commit "update"
(g, u) <- liftAnnex $ (,)
<$> gitRepo
@@ -279,8 +284,8 @@ handlePushInitiation checkcloudrepos (Pushing cid PushRequest) =
(taggedPush u selfjid branch r)
(handleDeferred checkcloudrepos)
checkcloudrepos r
-handlePushInitiation checkcloudrepos (Pushing cid StartingPush) = do
- rs <- xmppRemotes cid
+handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
+ rs <- xmppRemotes cid theiruuid
unless (null rs) $ do
void $ alertWhile (syncAlert rs) $
xmppReceivePack cid (handleDeferred checkcloudrepos)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 01:27:33 +0000