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.
This commit is contained in:
parent
11f8ea2f34
commit
5ac15149cc
7 changed files with 36 additions and 28 deletions
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
2
debian/changelog
vendored
2
debian/changelog
vendored
|
@ -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.
|
||||
|
|
|
@ -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**
|
||||
|
||||
|
|
Loading…
Reference in a new issue