drop unwanted content in the transfer scan

This was complicated quite a bit by needing to check numcopies. I optimised
that, so it only looks up numcopies once per file, no matter how many
remotes it checks to drop from. Although it did just occur to me that
it might be better to first check if it wants to drop content, and only
then check numcopies..
This commit is contained in:
Joey Hess 2012-10-18 14:55:59 -04:00
parent dbe8de40ab
commit f7f34d2072
3 changed files with 57 additions and 14 deletions

View file

@ -15,14 +15,17 @@ import Assistant.DaemonStatus
import Assistant.Alert import Assistant.Alert
import Logs.Transfer import Logs.Transfer
import Logs.Location import Logs.Location
import Logs.Trust
import Logs.Web (webUUID) import Logs.Web (webUUID)
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Utility.ThreadScheduler import Utility.ThreadScheduler
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
import qualified Command.Drop
import Command import Command
import Annex.Content import Annex.Content
import Annex.Wanted import Annex.Wanted
import Config
import qualified Data.Set as S import qualified Data.Set as S
@ -118,27 +121,67 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do
debug thisThread ["queuing", show t] debug thisThread ["queuing", show t]
queueTransferWhenSmall transferqueue dstatus (Just f) t r queueTransferWhenSmall transferqueue dstatus (Just f) t r
findtransfers f (key, _) = do findtransfers f (key, _) = do
locs <- S.fromList <$> loggedLocations key locs <- loggedLocations key
{- Queue transfers from any syncable remote. The {- The syncable remotes may have changed since this
- syncable remotes may have changed since this
- scan began. -} - scan began. -}
let use a = do
syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus
return $ catMaybes $ map (a key locs) syncrs present <- inAnnex key
ifM (inAnnex key)
( filterM (wantSend (Just f) . Remote.uuid . fst) handleDrops locs syncrs present f key
let slocs = S.fromList locs
let use a = return $ catMaybes $ map (a key slocs) syncrs
if present
then filterM (wantSend (Just f) . Remote.uuid . fst)
=<< use (genTransfer Upload False) =<< use (genTransfer Upload False)
, ifM (wantGet $ Just f) else ifM (wantGet $ Just f)
( use (genTransfer Download True) , return [] ) ( use (genTransfer Download True) , return [] )
)
genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
genTransfer direction want key locs r genTransfer direction want key slocs r
| direction == Upload && Remote.readonly r = Nothing | direction == Upload && Remote.readonly r = Nothing
| (S.member (Remote.uuid r) locs) == want = Just | (S.member (Remote.uuid r) slocs) == want = Just
(r, Transfer direction (Remote.uuid r) key) (r, Transfer direction (Remote.uuid r) key)
| otherwise = Nothing | otherwise = Nothing
{- Drop from local or remote when allowed by the preferred content and
- numcopies settings. -}
handleDrops :: [UUID] -> [Remote] -> Bool -> FilePath -> Key -> Annex ()
handleDrops locs rs present f key
| present = do
n <- getcopies
if checkcopies n
then go rs =<< dropl n
else go rs n
| otherwise = go rs =<< getcopies
where
getcopies = do
have <- length . snd <$> trustPartition UnTrusted locs
numcopies <- getNumCopies =<< numCopies f
return (have, numcopies)
checkcopies (have, numcopies) = have > numcopies
decrcopies (have, numcopies) = (have - 1, numcopies)
go [] _ = noop
go (r:rest) n
| checkcopies n = dropr r n >>= go rest
| otherwise = noop
checkdrop n@(_, numcopies) u a =
ifM (wantDrop u (Just f))
( ifM (doCommand $ a (Just numcopies))
( return $ decrcopies n
, return n
)
, return n
)
dropl n = checkdrop n Nothing $ \numcopies ->
Command.Drop.startLocal f numcopies key
dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
Command.Drop.startRemote f numcopies key r
remoteHas :: Remote -> Key -> Annex Bool remoteHas :: Remote -> Key -> Annex Bool
remoteHas r key = elem remoteHas r key = elem
<$> pure (Remote.uuid r) <$> pure (Remote.uuid r)

View file

@ -48,7 +48,7 @@ startLocal file numcopies key = stopUnless (inAnnex key) $ do
startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart
startRemote file numcopies key remote = do startRemote file numcopies key remote = do
showStart "drop" file showStart ("drop " ++ Remote.name remote) file
next $ performRemote key numcopies remote next $ performRemote key numcopies remote
performLocal :: Key -> Maybe Int -> CommandPerform performLocal :: Key -> Maybe Int -> CommandPerform

View file

@ -30,7 +30,7 @@ the same content, this gets tricky. Let's assume there are not.)
1. The preferred content expression can change, or a new repo is added, or 1. The preferred content expression can change, or a new repo is added, or
groups change. Generally, some change to global annex state. Only way to deal groups change. Generally, some change to global annex state. Only way to deal
with this is an expensive scan. (The rest of the items below come from with this is an expensive scan. (The rest of the items below come from
analizing the terminals used in preferred content expressions.) analizing the terminals used in preferred content expressions.) **done**
2. renaming of a file (ie, moved to `archive/`) 2. renaming of a file (ie, moved to `archive/`)
3. some other repository gets the file (`in`, `copies`) 3. some other repository gets the file (`in`, `copies`)
4. some other repository drops the file (`in`, `copies` .. However, it's 4. some other repository drops the file (`in`, `copies` .. However, it's