From 5aca7af2f702aa508ec5949e1fddbee429a93db5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 9 Oct 2012 12:18:41 -0400 Subject: assistant: Now honors preferred content settings when deciding what to transfer. Both when queueing downloads, and uploads, consults the preferred content settings. I didn't make it check yet when requeing failed transfers or queuing deferred downloads; dealing with the preferred content settings (or indeed, other settings) changing while the assistant is running still needs work. --- Annex/Wanted.hs | 7 +++---- Assistant/Threads/Committer.hs | 2 +- Assistant/Threads/TransferScanner.hs | 15 ++++++++------ Assistant/TransferQueue.hs | 33 ++++++++++++++++-------------- Command/Copy.hs | 2 +- debian/changelog | 2 ++ doc/design/assistant/transfer_control.mdwn | 3 ++- 7 files changed, 36 insertions(+), 28 deletions(-) diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs index 8310fdd8f..d7c28efad 100644 --- a/Annex/Wanted.hs +++ b/Annex/Wanted.hs @@ -10,7 +10,6 @@ module Annex.Wanted where import Common.Annex import Logs.PreferredContent import Git.FilePath -import qualified Annex import Annex.UUID import Types.Remote @@ -24,9 +23,9 @@ wantGet (Just file) = do isPreferredContent Nothing S.empty fp {- Check if a file is preferred content for a remote. -} -wantSend :: UUID -> AssociatedFile -> Annex Bool -wantSend _ Nothing = return True -wantSend to (Just file) = do +wantSend :: AssociatedFile -> UUID -> Annex Bool +wantSend Nothing _ = return True +wantSend (Just file) to = do fp <- inRepo $ toTopFilePath file isPreferredContent (Just to) S.empty fp diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 6b036d09a..b791dcc82 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -210,7 +210,7 @@ handleAdds delayadd st changechan transferqueue dstatus cs = returnWhen (null in sha <- inRepo $ Git.HashObject.hashObject BlobObject link stageSymlink file sha - queueTransfers Next transferqueue dstatus key (Just file) Upload + queueTransfers Next transferqueue dstatus st key (Just file) Upload showEndOk return $ Just change diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index cb02ed2f2..85275374d 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -22,6 +22,7 @@ import Utility.ThreadScheduler import qualified Git.LsFiles as LsFiles import Command import Annex.Content +import Annex.Wanted import qualified Data.Set as S @@ -105,18 +106,20 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do in if null rs' then rs else rs' go [] = noop go (f:fs) = do - mapM_ (enqueue f) =<< catMaybes <$> runThreadState st - (ifAnnexed f findtransfers $ return []) + mapM_ (enqueue f) =<< runThreadState st + (ifAnnexed f (findtransfers f) $ return []) go fs enqueue f (r, t) = do debug thisThread ["queuing", show t] queueTransferWhenSmall transferqueue dstatus (Just f) t r - findtransfers (key, _) = do + findtransfers f (key, _) = do locs <- loggedLocations key - let use a = return $ map (a key locs) rs + let use a = return $ catMaybes $ map (a key locs) rs ifM (inAnnex key) - ( use $ check Upload False - , use $ check Download True + ( filterM (wantSend (Just f) . Remote.uuid . fst) + =<< use (check Upload False) + , ifM (wantGet $ Just f) + ( use (check Download True) , return [] ) ) check direction want key locs r | direction == Upload && Remote.readonly r = Nothing diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index e2c3f167b..9b081d32e 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -27,6 +27,7 @@ import Logs.Transfer import Types.Remote import qualified Remote import qualified Types.Remote as Remote +import Annex.Wanted import Control.Concurrent.STM import qualified Data.Map as M @@ -56,22 +57,26 @@ stubInfo f r = stubTransferInfo , associatedFile = f } -{- Adds transfers to queue for some of the known remotes. -} +{- Adds transfers to queue for some of the known remotes. + - Honors preferred content settings, only transferring wanted files. -} queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () queueTransfers = queueTransfersMatching (const True) {- Adds transfers to queue for some of the known remotes, that match a - - condition. -} + - condition. Honors preferred content settings. -} queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () -queueTransfersMatching matching schedule q dstatus k f direction = do - rs <- sufficientremotes - =<< knownRemotes <$> liftIO (getDaemonStatus dstatus) - let matchingrs = filter (matching . Remote.uuid) rs - if null matchingrs - then defer - else forM_ matchingrs $ \r -> liftIO $ - enqueue schedule q dstatus (gentransfer r) (stubInfo f r) +queueTransfersMatching matching schedule q dstatus k f direction + | direction == Download = whenM (wantGet f) go + | otherwise = go where + go = do + rs <- sufficientremotes + =<< knownRemotes <$> liftIO (getDaemonStatus dstatus) + let matchingrs = filter (matching . Remote.uuid) rs + if null matchingrs + then defer + else forM_ matchingrs $ \r -> liftIO $ + enqueue schedule q dstatus (gentransfer r) (stubInfo f r) sufficientremotes rs {- Queue downloads from all remotes that - have the key, with the cheapest ones first. @@ -80,11 +85,9 @@ queueTransfersMatching matching schedule q dstatus k f direction = do | direction == Download = do uuids <- Remote.keyLocations k return $ filter (\r -> uuid r `elem` uuids) rs - {- TODO: Determine a smaller set of remotes that - - can be uploaded to, in order to ensure all - - remotes can access the content. Currently, - - send to every remote we can. -} - | otherwise = return $ filter (not . Remote.readonly) rs + {- Upload to all remotes that want the content. -} + | otherwise = filterM (wantSend f . Remote.uuid) $ + filter (not . Remote.readonly) rs gentransfer r = Transfer { transferDirection = direction , transferKey = k diff --git a/Command/Copy.hs b/Command/Copy.hs index f044facf4..4352aaa31 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -32,4 +32,4 @@ start to from file (key, backend) = autoCopies file key (<) $ where shouldCopy = case to of Nothing -> checkAuto $ wantGet (Just file) - Just r -> checkAuto $ wantSend (Remote.uuid r) (Just file) + Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r) diff --git a/debian/changelog b/debian/changelog index d81668d75..ed3cf9ebc 100644 --- a/debian/changelog +++ b/debian/changelog @@ -13,6 +13,8 @@ git-annex (3.20121002) UNRELEASED; urgency=low * drop --auto: If the repository the content is dropped from has preferred content configured, drop only content that is not preferred. * copy --auto: Only transfer content that the destination repository prefers. + * assistant: Now honors preferred content settings when deciding what to + transfer. * --copies=group:number can now be used to match files that are present in a specified number of repositories in a group. * Added --smallerthan, --largerthan, and --inall limits. diff --git a/doc/design/assistant/transfer_control.mdwn b/doc/design/assistant/transfer_control.mdwn index 1f53a5603..609329907 100644 --- a/doc/design/assistant/transfer_control.mdwn +++ b/doc/design/assistant/transfer_control.mdwn @@ -6,7 +6,8 @@ it doesn't currently have, is covered by the [[partial_content]] page. But often the remote is just a removable drive or a cloud remote, that has a limited size. This page is about making the assistant do -something smart with such remotes. +something smart with such remotes. (Which it now does.. **done** except for +an easy way to configure this.) ## specifying what data a remote prefers to contain **done** -- cgit v1.2.3