add TransferScanner thread
Efficiently finding transfers that need to be done to get two repos back in sync seems like an interesting problem.
This commit is contained in:
parent
26e4e65307
commit
522f568450
6 changed files with 138 additions and 43 deletions
|
@ -13,6 +13,8 @@ module Assistant.Threads.MountWatcher where
|
|||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.Threads.Pusher (pushToRemotes)
|
||||
import qualified Annex
|
||||
import qualified Git
|
||||
import Utility.ThreadScheduler
|
||||
|
@ -27,6 +29,7 @@ import Logs.Remote
|
|||
import Control.Concurrent
|
||||
import qualified Control.Exception as E
|
||||
import qualified Data.Set as S
|
||||
import Data.Time.Clock
|
||||
|
||||
#if WITH_DBUS
|
||||
import DBus.Client
|
||||
|
@ -39,18 +42,18 @@ import Data.Word (Word32)
|
|||
thisThread :: ThreadName
|
||||
thisThread = "MountWatcher"
|
||||
|
||||
mountWatcherThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
||||
mountWatcherThread st handle =
|
||||
mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
|
||||
mountWatcherThread st handle scanremotes =
|
||||
#if WITH_DBUS
|
||||
dbusThread st handle
|
||||
dbusThread st handle scanremotes
|
||||
#else
|
||||
pollingThread st handle
|
||||
pollingThread st handle scanremotes
|
||||
#endif
|
||||
|
||||
#if WITH_DBUS
|
||||
|
||||
dbusThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
||||
dbusThread st dstatus = E.catch (go =<< connectSession) onerr
|
||||
dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
|
||||
dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr
|
||||
where
|
||||
go client = ifM (checkMountMonitor client)
|
||||
( do
|
||||
|
@ -63,7 +66,7 @@ dbusThread st dstatus = E.catch (go =<< connectSession) onerr
|
|||
listen client matcher $ \_event -> do
|
||||
nowmounted <- currentMountPoints
|
||||
wasmounted <- swapMVar mvar nowmounted
|
||||
handleMounts st dstatus wasmounted nowmounted
|
||||
handleMounts st dstatus scanremotes wasmounted nowmounted
|
||||
, do
|
||||
runThreadState st $
|
||||
warning "No known volume monitor available through dbus; falling back to mtab polling"
|
||||
|
@ -74,7 +77,7 @@ dbusThread st dstatus = E.catch (go =<< connectSession) onerr
|
|||
runThreadState st $
|
||||
warning $ "Failed to use dbus; falling back to mtab polling (" ++ show e ++ ")"
|
||||
pollinstead
|
||||
pollinstead = pollingThread st dstatus
|
||||
pollinstead = pollingThread st dstatus scanremotes
|
||||
|
||||
type ServiceName = String
|
||||
|
||||
|
@ -140,30 +143,32 @@ mountAdded = [gvfs, kde]
|
|||
|
||||
#endif
|
||||
|
||||
pollingThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
||||
pollingThread st dstatus = go =<< currentMountPoints
|
||||
pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
|
||||
pollingThread st dstatus scanremotes = go =<< currentMountPoints
|
||||
where
|
||||
go wasmounted = do
|
||||
threadDelaySeconds (Seconds 10)
|
||||
nowmounted <- currentMountPoints
|
||||
handleMounts st dstatus wasmounted nowmounted
|
||||
handleMounts st dstatus scanremotes wasmounted nowmounted
|
||||
go nowmounted
|
||||
|
||||
handleMounts :: ThreadState -> DaemonStatusHandle -> MountPoints -> MountPoints -> IO ()
|
||||
handleMounts st dstatus wasmounted nowmounted = mapM_ (handleMount st dstatus) $
|
||||
handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> MountPoints -> MountPoints -> IO ()
|
||||
handleMounts st dstatus scanremotes wasmounted nowmounted = mapM_ (handleMount st dstatus scanremotes) $
|
||||
S.toList $ newMountPoints wasmounted nowmounted
|
||||
|
||||
handleMount :: ThreadState -> DaemonStatusHandle -> Mntent -> IO ()
|
||||
handleMount st dstatus mntent = do
|
||||
handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Mntent -> IO ()
|
||||
handleMount st dstatus scanremotes mntent = do
|
||||
debug thisThread ["detected mount of", mnt_dir mntent]
|
||||
rs <- remotesUnder st dstatus mntent
|
||||
unless (null rs) $ do
|
||||
branch <- runThreadState st $ Command.Sync.currentBranch
|
||||
let pullrs = filter Git.repoIsLocal rs
|
||||
debug thisThread ["pulling from", show pullrs]
|
||||
runThreadState st $ manualPull branch pullrs
|
||||
-- TODO queue transfers for new files in both directions
|
||||
where
|
||||
let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs
|
||||
unless (null nonspecial) $ do
|
||||
debug thisThread ["pulling from", show nonspecial]
|
||||
runThreadState st $ manualPull branch nonspecial
|
||||
now <- getCurrentTime
|
||||
pushToRemotes thisThread now st Nothing nonspecial
|
||||
addScanRemotes scanremotes rs
|
||||
|
||||
{- Finds remotes located underneath the mount point.
|
||||
-
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
{- git-annex assistant git pushing threads
|
||||
{- git-annex assistant git pushing thread
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
|
@ -36,7 +36,7 @@ pushRetryThread st pushmap = runEvery (Seconds halfhour) $ do
|
|||
, "failed pushes"
|
||||
]
|
||||
now <- getCurrentTime
|
||||
pushToRemotes now st pushmap topush
|
||||
pushToRemotes thisThread now st (Just pushmap) topush
|
||||
where
|
||||
halfhour = 1800
|
||||
|
||||
|
@ -53,7 +53,7 @@ pushThread st daemonstatus commitchan pushmap = do
|
|||
then do
|
||||
remotes <- runThreadState st $
|
||||
knownRemotes <$> getDaemonStatus daemonstatus
|
||||
pushToRemotes now st pushmap remotes
|
||||
pushToRemotes thisThread now st (Just pushmap) remotes
|
||||
else do
|
||||
debug thisThread
|
||||
[ "delaying push of"
|
||||
|
@ -78,24 +78,27 @@ shouldPush _now commits
|
|||
-
|
||||
- Avoids running possibly long-duration commands in the Annex monad, so
|
||||
- as not to block other threads. -}
|
||||
pushToRemotes :: UTCTime -> ThreadState -> FailedPushMap -> [Remote] -> IO ()
|
||||
pushToRemotes now st pushmap remotes = do
|
||||
pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO ()
|
||||
pushToRemotes threadname now st mpushmap remotes = do
|
||||
(g, branch) <- runThreadState st $
|
||||
(,) <$> fromRepo id <*> Command.Sync.currentBranch
|
||||
go True branch g remotes
|
||||
where
|
||||
go shouldretry branch g rs = do
|
||||
debug thisThread
|
||||
debug threadname
|
||||
[ "pushing to"
|
||||
, show rs
|
||||
]
|
||||
Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
|
||||
(succeeded, failed) <- inParallel (push g branch) rs
|
||||
changeFailedPushMap pushmap $ \m ->
|
||||
M.union (makemap failed) $
|
||||
M.difference m (makemap succeeded)
|
||||
case mpushmap of
|
||||
Nothing -> noop
|
||||
Just pushmap ->
|
||||
changeFailedPushMap pushmap $ \m ->
|
||||
M.union (makemap failed) $
|
||||
M.difference m (makemap succeeded)
|
||||
unless (null failed) $
|
||||
debug thisThread
|
||||
debug threadname
|
||||
[ "failed to push to"
|
||||
, show failed
|
||||
]
|
||||
|
@ -109,6 +112,6 @@ pushToRemotes now st pushmap remotes = do
|
|||
( exitSuccess, exitFailure)
|
||||
|
||||
retry branch g rs = do
|
||||
debug thisThread [ "trying manual pull to resolve failed pushes" ]
|
||||
debug threadname [ "trying manual pull to resolve failed pushes" ]
|
||||
runThreadState st $ manualPull branch rs
|
||||
go False branch g rs
|
||||
|
|
34
Assistant/Threads/TransferScanner.hs
Normal file
34
Assistant/Threads/TransferScanner.hs
Normal file
|
@ -0,0 +1,34 @@
|
|||
{- git-annex assistant thread to scan remotes to find needed transfers
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Threads.TransferScanner where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.ThreadedMonad
|
||||
import Logs.Transfer
|
||||
import Types.Remote
|
||||
import Utility.ThreadScheduler
|
||||
|
||||
thisThread :: ThreadName
|
||||
thisThread = "TransferScanner"
|
||||
|
||||
{- This thread scans remotes, to find transfers that need to be made to
|
||||
- keep their data in sync. The transfers are queued with lot priority. -}
|
||||
transferScannerThread :: ThreadState -> ScanRemoteMap -> TransferQueue -> IO ()
|
||||
transferScannerThread st scanremotes transferqueue = do
|
||||
runEvery (Seconds 2) $ do
|
||||
r <- getScanRemote scanremotes
|
||||
needtransfer <- scan st r
|
||||
forM_ needtransfer $ \(f, t) ->
|
||||
queueLaterTransfer transferqueue f t
|
||||
|
||||
scan :: ThreadState -> Remote -> IO [(AssociatedFile, Transfer)]
|
||||
scan st r = do
|
||||
debug thisThread ["scanning", show r]
|
||||
return [] -- TODO
|
Loading…
Add table
Add a link
Reference in a new issue