From dc82128f6f0ffef9f6973baed3ad63d89802c898 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 6 Mar 2013 16:29:19 -0400 Subject: tag xmpp pushes with jid This fixes the issue mentioned in the last commit. Turns out just collecting UUID of clients behind a XMPP remote is insufficient (although I should probably still do it for other reasons), because a single remote repo might be connected via both XMPP and local pairing. So a way is needed to know when a push was received from any client using a given XMPP remote over XMPP, as opposed to via ssh. --- Annex/TaggedPush.hs | 42 +++++++++++++++++++++++++---------------- Assistant/Sync.hs | 15 +++++++++------ Assistant/Threads/Merger.hs | 25 ++++++++++++------------ Assistant/Threads/XMPPClient.hs | 24 ++++++++++++----------- Assistant/Types/DaemonStatus.hs | 4 ++++ Assistant/XMPP/Git.hs | 3 ++- Utility/Base64.hs | 12 +++++++++--- 7 files changed, 76 insertions(+), 49 deletions(-) diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs index f54ce756f..4f5125ce0 100644 --- a/Annex/TaggedPush.hs +++ b/Annex/TaggedPush.hs @@ -1,4 +1,4 @@ -{- git-annex uuid-tagged pushes +{- git-annex tagged pushes - - Copyright 2012 Joey Hess - @@ -13,9 +13,11 @@ import qualified Annex.Branch import qualified Git import qualified Git.Ref import qualified Git.Command +import Utility.Base64 {- Converts a git branch into a branch that is tagged with a UUID, typically - - the UUID of the repo that will be pushing it. + - the UUID of the repo that will be pushing it, and possibly with other + - information. - - Pushing to branches on the remote that have out uuid in them is ugly, - but it reserves those branches for pushing by us, and so our pushes will @@ -23,25 +25,33 @@ import qualified Git.Command - - To avoid cluttering up the branch display, the branch is put under - refs/synced/, rather than the usual refs/remotes/ + - + - Both UUIDs and Base64 encoded data are always legal to be used in git + - refs, per git-check-ref-format. -} -toTaggedBranch :: UUID -> Git.Branch -> Git.Branch -toTaggedBranch u b = Git.Ref $ concat - [ s - , ":" - , "refs/synced/" ++ fromUUID u ++ "/" ++ s +toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch +toTaggedBranch u info b = Git.Ref $ join "/" $ catMaybes + [ Just "refs/synced" + , Just $ fromUUID u + , toB64 <$> info + , Just $ show $ Git.Ref.base b ] - where - s = show $ Git.Ref.base b -branchTaggedBy :: Git.Branch -> Maybe UUID -branchTaggedBy b = case split "/" $ show b of - ("refs":"synced":u:_base) -> Just $ toUUID u +fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String) +fromTaggedBranch b = case split "/" $ show b of + ("refs":"synced":u:info:_base) -> + Just (toUUID u, fromB64Maybe info) + ("refs":"synced":u:_base) -> + Just (toUUID u, Nothing) _ -> Nothing + where -taggedPush :: UUID -> Git.Ref -> Remote -> Git.Repo -> IO Bool -taggedPush u branch remote = Git.Command.runBool +taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool +taggedPush u info branch remote = Git.Command.runBool [ Param "push" , Param $ Remote.name remote - , Param $ show $ toTaggedBranch u Annex.Branch.name - , Param $ show $ toTaggedBranch u branch + , Param $ refspec Annex.Branch.name + , Param $ refspec branch ] + where + refspec b = show b ++ ":" ++ show (toTaggedBranch u info b) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index f8dcd6748..901694920 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -48,11 +48,9 @@ reconnectRemotes _ [] = noop reconnectRemotes notifypushes rs = void $ do modifyDaemonStatus_ $ \s -> s { desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) } - alertWhile (syncAlert normalremotes) $ do - (ok, diverged) <- sync - =<< liftAnnex (inRepo Git.Branch.current) - addScanRemotes diverged rs - return ok + if null normalremotes + then go + else alertWhile (syncAlert normalremotes) go where gitremotes = filter (notspecialremote . Remote.repo) rs (xmppremotes, normalremotes) = partition isXMPPRemote gitremotes @@ -69,6 +67,11 @@ reconnectRemotes notifypushes rs = void $ do sync Nothing = do diverged <- snd <$> manualPull Nothing gitremotes return (True, diverged) + go = do + (ok, diverged) <- sync + =<< liftAnnex (inRepo Git.Branch.current) + addScanRemotes diverged rs + return ok {- Updates the local sync branch, then pushes it to all remotes, in - parallel, along with the git-annex branch. This is the same @@ -137,7 +140,7 @@ pushToRemotes now notifypushes remotes = do fallback branch g u rs = do debug ["fallback pushing to", show rs] (succeeded, failed) <- liftIO $ - inParallel (\r -> taggedPush u branch r g) rs + inParallel (\r -> taggedPush u Nothing branch r g) rs updatemap succeeded failed when (notifypushes && (not $ null succeeded)) $ sendNetMessage $ NotifyPush $ diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index d88cf00bd..4a482583f 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -22,6 +22,7 @@ import Annex.TaggedPush import Remote (remoteFromUUID) import qualified Data.Set as S +import qualified Data.Text as T {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} @@ -89,21 +90,21 @@ onAdd file void $ liftAnnex $ Command.Sync.mergeFrom changedbranch mergecurrent _ = noop - handleDesynced = case branchTaggedBy changedbranch of + handleDesynced = case fromTaggedBranch changedbranch of Nothing -> return False - Just u -> do - s <- desynced <$> getDaemonStatus - if S.member u s - then do - modifyDaemonStatus_ $ \st -> st - { desynced = S.delete u s } - mr <- liftAnnex $ remoteFromUUID u - case mr of - Just r -> do + Just (u, info) -> do + mr <- liftAnnex $ remoteFromUUID u + case mr of + Nothing -> return False + Just r -> do + s <- desynced <$> getDaemonStatus + if S.member u s || Just (T.unpack $ getXMPPClientID r) == info + then do + modifyDaemonStatus_ $ \st -> st + { desynced = S.delete u s } addScanRemotes True [r] return True - Nothing -> return False - else return False + else return False equivBranches :: Git.Ref -> Git.Ref -> Bool equivBranches x y = base x == base y diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index ebface796..688d0121b 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -38,18 +38,20 @@ xmppClientThread urlrenderer = namedThread "XMPPClient" $ restartableClient . xmppClient urlrenderer =<< getAssistant id {- Runs the client, handing restart events. -} -restartableClient :: IO () -> Assistant () -restartableClient a = forever $ do - tid <- liftIO $ forkIO a - waitNetMessagerRestart - liftIO $ killThread tid +restartableClient :: (XMPPCreds -> IO ()) -> Assistant () +restartableClient a = forever $ go =<< liftAnnex getXMPPCreds + where + go Nothing = waitNetMessagerRestart + go (Just creds) = do + modifyDaemonStatus_ $ \s -> s + { xmppClientID = Just $ xmppJID creds } + tid <- liftIO $ forkIO $ a creds + waitNetMessagerRestart + liftIO $ killThread tid -xmppClient :: UrlRenderer -> AssistantData -> IO () -xmppClient urlrenderer d = do - v <- liftAssistant $ liftAnnex getXMPPCreds - case v of - Nothing -> noop -- will be restarted once creds get configured - Just c -> retry (runclient c) =<< getCurrentTime +xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO () +xmppClient urlrenderer d creds = + retry (runclient creds) =<< getCurrentTime where liftAssistant = runAssistant d inAssistant = liftIO . liftAssistant diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 7da85daa0..a22223476 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -15,6 +15,7 @@ import Assistant.Pairing import Utility.NotificationBroadcaster import Logs.Transfer import Assistant.Types.ThreadName +import Assistant.Types.NetMessager import Control.Concurrent.STM import Control.Concurrent.Async @@ -57,6 +58,8 @@ data DaemonStatus = DaemonStatus , alertNotifier :: NotificationBroadcaster -- Broadcasts notifications when the syncRemotes change , syncRemotesNotifier :: NotificationBroadcaster + -- When the XMPP client is in use, this will contain its JI. + , xmppClientID :: Maybe ClientID } type TransferMap = M.Map Transfer TransferInfo @@ -83,3 +86,4 @@ newDaemonStatus = DaemonStatus <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster + <*> pure Nothing diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index b5c8e382c..bdb68eea1 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -264,7 +264,8 @@ handlePushInitiation (Pushing cid PushRequest) = <*> getUUID liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g debug ["pushing to", show rs] - forM_ rs $ \r -> xmppPush cid $ taggedPush u branch r + selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus + forM_ rs $ \r -> xmppPush cid $ taggedPush u selfjid branch r handlePushInitiation (Pushing cid StartingPush) = whenXMPPRemote cid $ void $ xmppReceivePack cid diff --git a/Utility/Base64.hs b/Utility/Base64.hs index ed803a00a..ec660108a 100644 --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -5,14 +5,20 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Utility.Base64 (toB64, fromB64) where +module Utility.Base64 (toB64, fromB64Maybe, fromB64) where import Codec.Binary.Base64 import Data.Bits.Utils +import Control.Applicative +import Data.Maybe toB64 :: String -> String toB64 = encode . s2w8 +fromB64Maybe :: String -> Maybe String +fromB64Maybe s = w82s <$> decode s + fromB64 :: String -> String -fromB64 s = maybe bad w82s $ decode s - where bad = error "bad base64 encoded data" +fromB64 = fromMaybe bad . fromB64Maybe + where + bad = error "bad base64 encoded data" -- cgit v1.2.3