pull from one of the remotes in a push notification
Still need to do something about transfer queueing, however. This could be a real can of worms.
This commit is contained in:
parent
32254488da
commit
422b426460
3 changed files with 39 additions and 10 deletions
|
@ -48,13 +48,13 @@ reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
|
||||||
(gitremotes, _specialremotes) =
|
(gitremotes, _specialremotes) =
|
||||||
partition (Git.repoIsUrl . Remote.repo) rs
|
partition (Git.repoIsUrl . Remote.repo) rs
|
||||||
sync (Just branch) = do
|
sync (Just branch) = do
|
||||||
diverged <- manualPull st (Just branch) gitremotes
|
diverged <- snd <$> manualPull st (Just branch) gitremotes
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes
|
ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes
|
||||||
return (ok, diverged)
|
return (ok, diverged)
|
||||||
{- No local branch exists yet, but we can try pulling. -}
|
{- No local branch exists yet, but we can try pulling. -}
|
||||||
sync Nothing = do
|
sync Nothing = do
|
||||||
diverged <- manualPull st Nothing gitremotes
|
diverged <- snd <$> manualPull st Nothing gitremotes
|
||||||
return (True, diverged)
|
return (True, diverged)
|
||||||
|
|
||||||
{- Updates the local sync branch, then pushes it to all remotes, in
|
{- Updates the local sync branch, then pushes it to all remotes, in
|
||||||
|
@ -147,15 +147,15 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do
|
||||||
where s = show $ Git.Ref.base b
|
where s = show $ Git.Ref.base b
|
||||||
|
|
||||||
{- Manually pull from remotes and merge their branches. -}
|
{- Manually pull from remotes and merge their branches. -}
|
||||||
manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool
|
manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO ([Bool], Bool)
|
||||||
manualPull st currentbranch remotes = do
|
manualPull st currentbranch remotes = do
|
||||||
g <- runThreadState st gitRepo
|
g <- runThreadState st gitRepo
|
||||||
forM_ remotes $ \r ->
|
results <- forM remotes $ \r ->
|
||||||
Git.Command.runBool "fetch" [Param $ Remote.name r] g
|
Git.Command.runBool "fetch" [Param $ Remote.name r] g
|
||||||
haddiverged <- runThreadState st Annex.Branch.forceUpdate
|
haddiverged <- runThreadState st Annex.Branch.forceUpdate
|
||||||
forM_ remotes $ \r ->
|
forM_ remotes $ \r ->
|
||||||
runThreadState st $ Command.Sync.mergeRemote r currentbranch
|
runThreadState st $ Command.Sync.mergeRemote r currentbranch
|
||||||
return haddiverged
|
return (results, haddiverged)
|
||||||
|
|
||||||
{- Start syncing a newly added remote, using a background thread. -}
|
{- Start syncing a newly added remote, using a background thread. -}
|
||||||
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
|
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
|
||||||
|
|
|
@ -14,6 +14,7 @@ import Assistant.Common
|
||||||
import Assistant.ThreadedMonad
|
import Assistant.ThreadedMonad
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.Pushes
|
import Assistant.Pushes
|
||||||
|
import Assistant.Sync
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
|
|
||||||
import Network.Protocol.XMPP
|
import Network.Protocol.XMPP
|
||||||
|
@ -22,6 +23,7 @@ import Control.Concurrent
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
import Utility.FileMode
|
import Utility.FileMode
|
||||||
|
import qualified Git.Branch
|
||||||
|
|
||||||
thisThread :: ThreadName
|
thisThread :: ThreadName
|
||||||
thisThread = "PushNotifier"
|
thisThread = "PushNotifier"
|
||||||
|
@ -62,7 +64,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do
|
||||||
s <- getStanza
|
s <- getStanza
|
||||||
case s of
|
case s of
|
||||||
ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) ->
|
ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) ->
|
||||||
maybe noop (liftIO . pull dstatus)
|
maybe noop (liftIO . pull st dstatus)
|
||||||
(decodePushNotification t)
|
(decodePushNotification t)
|
||||||
_ -> noop
|
_ -> noop
|
||||||
|
|
||||||
|
@ -118,11 +120,31 @@ decodePushNotification :: T.Text -> Maybe [UUID]
|
||||||
decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim
|
decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim
|
||||||
<$> T.stripPrefix prefix t
|
<$> T.stripPrefix prefix t
|
||||||
|
|
||||||
pull :: DaemonStatusHandle -> [UUID] -> IO ()
|
{- We only pull from one remote out of the set listed in the push
|
||||||
pull _ [] = noop
|
- notification, as an optimisation.
|
||||||
pull dstatus us = do
|
-
|
||||||
|
- Note that it might be possible (though very unlikely) for the push
|
||||||
|
- notification to take a while to be sent, and multiple pushes happen
|
||||||
|
- before it is sent, so it includes multiple remotes that were pushed
|
||||||
|
- to at different times.
|
||||||
|
-
|
||||||
|
- It could then be the case that the remote we choose had the earlier
|
||||||
|
- push sent to it, but then failed to get the later push, and so is not
|
||||||
|
- fully up-to-date. If that happens, the pushRetryThread will come along
|
||||||
|
- and retry the push, and we'll get another notification once it succeeds,
|
||||||
|
- and pull again. -}
|
||||||
|
pull :: ThreadState -> DaemonStatusHandle -> [UUID] -> IO ()
|
||||||
|
pull _ _ [] = noop
|
||||||
|
pull st dstatus us = do
|
||||||
rs <- filter matching . syncRemotes <$> getDaemonStatus dstatus
|
rs <- filter matching . syncRemotes <$> getDaemonStatus dstatus
|
||||||
print ("TODO pull from", rs)
|
debug thisThread $ "push notification for" :
|
||||||
|
map (fromUUID . Remote.uuid ) rs
|
||||||
|
pullone rs =<< runThreadState st (inRepo Git.Branch.current)
|
||||||
where
|
where
|
||||||
matching r = Remote.uuid r `S.member` s
|
matching r = Remote.uuid r `S.member` s
|
||||||
s = S.fromList us
|
s = S.fromList us
|
||||||
|
|
||||||
|
pullone [] _ = noop
|
||||||
|
pullone (r:rs) branch =
|
||||||
|
unlessM (all id . fst <$> manualPull st branch [r]) $
|
||||||
|
pullone rs branch
|
||||||
|
|
|
@ -52,6 +52,13 @@ the assistant will transfer the file from the cloud to Bob.
|
||||||
* Make the git-annex clients invisible, so a user can use their regular
|
* Make the git-annex clients invisible, so a user can use their regular
|
||||||
account without always seeming to be present when git-annex is logged in.
|
account without always seeming to be present when git-annex is logged in.
|
||||||
See <http://xmpp.org/extensions/xep-0126.html>
|
See <http://xmpp.org/extensions/xep-0126.html>
|
||||||
|
* webapp configuration
|
||||||
|
* After pulling from a remote, may need to scan for transfers, which
|
||||||
|
could involve other remotes (ie, S3). Since the remote client is not able to
|
||||||
|
talk to us directly, it won't be able to upload any new files to us.
|
||||||
|
Need a fast way to find new files, and get them transferring. The expensive
|
||||||
|
transfer scan may be needed to get fully in sync, but is too expensive to
|
||||||
|
run every time this happens.
|
||||||
|
|
||||||
### jabber security
|
### jabber security
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue