diff options
| -rw-r--r-- | Annex/TaggedPush.hs | 57 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 62 | ||||
| -rw-r--r-- | Assistant/Threads/Merger.hs | 30 | ||||
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 24 | ||||
| -rw-r--r-- | Assistant/Types/DaemonStatus.hs | 8 | ||||
| -rw-r--r-- | Assistant/XMPP/Git.hs | 6 | ||||
| -rw-r--r-- | Utility/Base64.hs | 12 | ||||
| -rw-r--r-- | debian/changelog | 2 | ||||
| -rw-r--r-- | doc/design/assistant/blog/day_205_206__rainy_day__snow_day.mdwn | 12 | ||||
| -rw-r--r-- | doc/design/assistant/xmpp.mdwn | 2 |
10 files changed, 164 insertions, 51 deletions
diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs new file mode 100644 index 000000000..4f5125ce0 --- /dev/null +++ b/Annex/TaggedPush.hs @@ -0,0 +1,57 @@ +{- git-annex tagged pushes + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.TaggedPush where + +import Common.Annex +import qualified Remote +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, 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 + - never conflict with other pushes. + - + - 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 -> 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 + ] + +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 -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool +taggedPush u info branch remote = Git.Command.runBool + [ Param "push" + , Param $ Remote.name remote + , 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 8546aa318..901694920 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -18,15 +18,16 @@ import qualified Command.Sync import Utility.Parallel import qualified Git import qualified Git.Branch -import qualified Git.Ref import qualified Git.Command import qualified Remote import qualified Types.Remote as Remote import qualified Annex.Branch import Annex.UUID +import Annex.TaggedPush import Data.Time.Clock import qualified Data.Map as M +import qualified Data.Set as S import Control.Concurrent {- Syncs with remotes that may have been disconnected for a while. @@ -36,17 +37,23 @@ import Control.Concurrent - An expensive full scan is queued when the git-annex branches of some of - the remotes have diverged from the local git-annex branch. Otherwise, - it's sufficient to requeue failed transfers. + - + - XMPP remotes are also signaled that we can push to them, and we request + - they push to us. Since XMPP pushes run ansynchronously, any scan of the + - XMPP remotes has to be deferred until they're done pushing to us, so + - all XMPP remotes are marked as possibly desynced. -} reconnectRemotes :: Bool -> [Remote] -> Assistant () reconnectRemotes _ [] = noop reconnectRemotes notifypushes rs = void $ do - alertWhile (syncAlert rs) $ do - (ok, diverged) <- sync - =<< liftAnnex (inRepo Git.Branch.current) - addScanRemotes diverged rs - return ok + modifyDaemonStatus_ $ \s -> s + { desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) } + if null normalremotes + then go + else alertWhile (syncAlert normalremotes) go where gitremotes = filter (notspecialremote . Remote.repo) rs + (xmppremotes, normalremotes) = partition isXMPPRemote gitremotes notspecialremote r | Git.repoIsUrl r = True | Git.repoIsLocal r = True @@ -60,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 @@ -128,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 -> pushFallback u branch r g) rs + inParallel (\r -> taggedPush u Nothing branch r g) rs updatemap succeeded failed when (notifypushes && (not $ null succeeded)) $ sendNetMessage $ NotifyPush $ @@ -137,35 +149,25 @@ pushToRemotes now notifypushes remotes = do push g branch remote = Command.Sync.pushBranch remote branch g -{- 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 - [ Param "push" - , Param $ Remote.name remote - , Param $ refspec Annex.Branch.name - , Param $ refspec branch - ] - 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 - -{- Manually pull from remotes and merge their branches. -} +{- Manually pull from remotes and merge their branches. Returns the results + - of all the pulls, and whether the git-annex branches of the remotes and + - local had divierged before the pull. + - + - After pulling from the normal git remotes, requests pushes from any XMPP + - remotes. However, those pushes will run asynchronously, so their + - results are not included in the return data. + -} manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool) manualPull currentbranch remotes = do g <- liftAnnex gitRepo - results <- liftIO $ forM remotes $ \r -> + let (xmppremotes, normalremotes) = partition isXMPPRemote remotes + results <- liftIO $ forM normalremotes $ \r -> Git.Command.runBool [Param "fetch", Param $ Remote.name r] g haddiverged <- liftAnnex Annex.Branch.forceUpdate - forM_ remotes $ \r -> + forM_ normalremotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch + forM_ xmppremotes $ \r -> + sendNetMessage $ Pushing (getXMPPClientID r) PushRequest return (results, haddiverged) {- Start syncing a newly added remote, using a background thread. -} diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 1488a2f0d..4a482583f 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -10,12 +10,19 @@ module Assistant.Threads.Merger where import Assistant.Common import Assistant.TransferQueue import Assistant.BranchChange +import Assistant.DaemonStatus +import Assistant.ScanRemotes import Utility.DirWatcher import Utility.Types.DirWatcher import qualified Annex.Branch import qualified Git import qualified Git.Branch import qualified Command.Sync +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. -} @@ -64,13 +71,16 @@ onAdd file | ".lock" `isSuffixOf` file = noop | isAnnexBranch file = do branchChanged - whenM (liftAnnex Annex.Branch.forceUpdate) $ - queueDeferredDownloads "retrying deferred download" Later + diverged <- liftAnnex Annex.Branch.forceUpdate + when diverged $ + unlessM handleDesynced $ + queueDeferredDownloads "retrying deferred download" Later | "/synced/" `isInfixOf` file = do mergecurrent =<< liftAnnex (inRepo Git.Branch.current) | otherwise = noop where changedbranch = fileToBranch file + mergecurrent (Just current) | equivBranches changedbranch current = do debug @@ -80,6 +90,22 @@ onAdd file void $ liftAnnex $ Command.Sync.mergeFrom changedbranch mergecurrent _ = noop + handleDesynced = case fromTaggedBranch changedbranch of + Nothing -> return False + 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 + else return False + equivBranches :: Git.Ref -> Git.Ref -> Bool equivBranches x y = base x == base y where 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 b60d49edf..a22223476 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -15,11 +15,13 @@ 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 import Data.Time.Clock.POSIX import qualified Data.Map as M +import qualified Data.Set as S data DaemonStatus = DaemonStatus -- All the named threads that comprise the daemon, @@ -44,6 +46,8 @@ data DaemonStatus = DaemonStatus , syncGitRemotes :: [Remote] -- Ordered list of remotes to sync data with , syncDataRemotes :: [Remote] + -- List of uuids of remotes that we may have gotten out of sync with. + , desynced :: S.Set UUID -- Pairing request that is in progress. , pairingInProgress :: Maybe PairingInProgress -- Broadcasts notifications about all changes to the DaemonStatus @@ -54,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 @@ -74,8 +80,10 @@ newDaemonStatus = DaemonStatus <*> pure [] <*> pure [] <*> pure [] + <*> pure S.empty <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster + <*> pure Nothing diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 8dba309a8..bdb68eea1 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -19,6 +19,7 @@ import Assistant.Sync import qualified Command.Sync import qualified Annex.Branch import Annex.UUID +import Annex.TaggedPush import Config import Git import qualified Git.Branch @@ -251,7 +252,6 @@ handlePushInitiation :: NetMessage -> Assistant () handlePushInitiation (Pushing cid CanPush) = whenXMPPRemote cid $ sendNetMessage $ Pushing cid PushRequest - handlePushInitiation (Pushing cid PushRequest) = go =<< liftAnnex (inRepo Git.Branch.current) where @@ -264,8 +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 $ pushFallback 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" diff --git a/debian/changelog b/debian/changelog index 8af9120b4..0cdec1fa1 100644 --- a/debian/changelog +++ b/debian/changelog @@ -25,6 +25,8 @@ git-annex (4.20130228) UNRELEASED; urgency=low since it is not possible to sanely use it. * Run ssh with -T to avoid tty allocation and any login scripts that may do undesired things with it. + * assistant: Get back in sync with XMPP remotes after network reconnection, + and on startup. -- Joey Hess <joeyh@debian.org> Wed, 27 Feb 2013 23:20:40 -0400 diff --git a/doc/design/assistant/blog/day_205_206__rainy_day__snow_day.mdwn b/doc/design/assistant/blog/day_205_206__rainy_day__snow_day.mdwn new file mode 100644 index 000000000..e1d07c8e4 --- /dev/null +++ b/doc/design/assistant/blog/day_205_206__rainy_day__snow_day.mdwn @@ -0,0 +1,12 @@ +Yesterday was all bug fixes, nothing to write about really. + +Today I've been working on getting XMPP remotes to sync more reliably. +I left some big holes when I stopped work on it in November: + +1. The assistant did not sync with XMPP remotes when it started up. +2. .. Or when it detected a network reconnection. +3. There was no way to trigger a full scan for transfers + after receiving a push from an XMPP remote. + +The asynchronous nature of git push over XMPP complicated doing this, but +I've solved all 3 issues today. diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 1c40aa102..fed79527e 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -9,8 +9,6 @@ who share a repository, that is stored in the [[cloud]]. * Do git-annex clients sharing an account with regular clients cause confusing things to happen? See <http://git-annex.branchable.com/design/assistant/blog/day_114__xmpp/#comment-aaba579f92cb452caf26ac53071a6788> -* Assistant.Sync.manualPull doesn't handle XMPP remotes yet. - This is needed to handle getting back in sync after reconnection. * Support use of a single XMPP account with several separate and independant git-annex repos. This probably works for the simple push notification use of XMPP, since unknown UUIDs will just be ignored. |