--auto fixes

* get/copy --auto: Transfer data even if it would exceed numcopies,
  when preferred content settings want it.
* drop --auto: Fix dropping content when there are no preferred content
  settings.
This commit is contained in:
Joey Hess 2012-12-06 13:22:16 -04:00
parent 28cfd6776d
commit 99a8a5297c
12 changed files with 50 additions and 48 deletions

View file

@ -15,19 +15,19 @@ import Types.Remote
import qualified Data.Set as S
{- Check if a file is preferred content for the local repository. -}
wantGet :: AssociatedFile -> Annex Bool
wantGet Nothing = return True
wantGet (Just file) = isPreferredContent Nothing S.empty file
wantGet :: Bool -> AssociatedFile -> Annex Bool
wantGet def Nothing = return def
wantGet def (Just file) = isPreferredContent Nothing S.empty file def
{- Check if a file is preferred content for a remote. -}
wantSend :: AssociatedFile -> UUID -> Annex Bool
wantSend Nothing _ = return True
wantSend (Just file) to = isPreferredContent (Just to) S.empty file
wantSend :: Bool -> AssociatedFile -> UUID -> Annex Bool
wantSend def Nothing _ = return def
wantSend def (Just file) to = isPreferredContent (Just to) S.empty file def
{- Check if a file can be dropped, maybe from a remote.
- Don't drop files that are preferred content. -}
wantDrop :: Maybe UUID -> AssociatedFile -> Annex Bool
wantDrop _ Nothing = return True
wantDrop from (Just file) = do
wantDrop :: Bool -> Maybe UUID -> AssociatedFile -> Annex Bool
wantDrop def _ Nothing = return $ not def
wantDrop def from (Just file) = do
u <- maybe getUUID (return . id) from
not <$> isPreferredContent (Just u) (S.singleton u) file
not <$> isPreferredContent (Just u) (S.singleton u) file def

View file

@ -58,7 +58,7 @@ handleDropsFrom locs rs fromhere key (Just f) knownpresentremote
| checkcopies n = dropr r n >>= go rest
| otherwise = noop
checkdrop n@(_, numcopies) u a = ifM (wantDrop u (Just f))
checkdrop n@(_, numcopies) u a = ifM (wantDrop True u (Just f))
( ifM (safely $ doCommand $ a (Just numcopies))
( return $ decrcopies n
, return n

View file

@ -124,9 +124,9 @@ expensiveScan rs = unless onlyweb $ do
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)
then filterM (wantSend True (Just f) . Remote.uuid . fst)
=<< use (genTransfer Upload False)
else ifM (wantGet $ Just f)
else ifM (wantGet True $ Just f)
( use (genTransfer Download True) , return [] )
genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)

View file

@ -52,7 +52,7 @@ queueTransfers = queueTransfersMatching (const True)
- condition. Honors preferred content settings. -}
queueTransfersMatching :: (UUID -> Bool) -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
queueTransfersMatching matching schedule k f direction
| direction == Download = whenM (liftAnnex $ wantGet f) go
| direction == Download = whenM (liftAnnex $ wantGet True f) go
| otherwise = go
where
go = do
@ -72,7 +72,7 @@ queueTransfersMatching matching schedule k f direction
uuids <- Remote.keyLocations k
return $ filter (\r -> uuid r `elem` uuids) rs
{- Upload to all remotes that want the content. -}
| otherwise = filterM (wantSend f . Remote.uuid) $
| otherwise = filterM (wantSend True f . Remote.uuid) $
filter (not . Remote.readonly) rs
gentransfer r = Transfer
{ transferDirection = direction

View file

@ -20,7 +20,7 @@ module Command (
notBareRepo,
isBareRepo,
numCopies,
autoCopies,
numCopiesCheck,
autoCopiesWith,
checkAuto,
module ReExported
@ -109,6 +109,13 @@ isBareRepo = fromRepo Git.repoIsLocalBare
numCopies :: FilePath -> Annex (Maybe Int)
numCopies file = readish <$> checkAttr "annex.numcopies" file
numCopiesCheck :: FilePath -> Key -> (Int -> Int -> Bool) -> Annex Bool
numCopiesCheck file key vs = do
numcopiesattr <- numCopies file
needed <- getNumCopies numcopiesattr
have <- trustExclude UnTrusted =<< Remote.keyLocations key
return $ length have `vs` needed
{- Used for commands that have an auto mode that checks the number of known
- copies of a key.
-
@ -116,16 +123,6 @@ numCopies file = readish <$> checkAttr "annex.numcopies" file
- copies of the key is > or < than the numcopies setting, before running
- the action.
-}
autoCopies :: FilePath -> Key -> (Int -> Int -> Bool) -> CommandStart -> CommandStart
autoCopies file key vs a = Annex.getState Annex.auto >>= go
where
go False = a
go True = do
numcopiesattr <- numCopies file
needed <- getNumCopies numcopiesattr
have <- trustExclude UnTrusted =<< Remote.keyLocations key
if length have `vs` needed then a else stop
autoCopiesWith :: FilePath -> Key -> (Int -> Int -> Bool) -> (Maybe Int -> CommandStart) -> CommandStart
autoCopiesWith file key vs a = do
numcopiesattr <- numCopies file

View file

@ -26,10 +26,11 @@ seek = [withField Command.Move.toOption Remote.byName $ \to ->
- However, --auto mode avoids unnecessary copies, and avoids getting or
- sending non-preferred content. -}
start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
start to from file (key, backend) = autoCopies file key (<) $
stopUnless shouldCopy $
Command.Move.start to from False file (key, backend)
start to from file (key, backend) = stopUnless shouldCopy $
Command.Move.start to from False file (key, backend)
where
shouldCopy = case to of
Nothing -> checkAuto $ wantGet (Just file)
Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r)
shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
check = case to of
Nothing -> wantGet False (Just file)
Just r -> wantSend False (Just file) (Remote.uuid r)

View file

@ -32,7 +32,7 @@ seek = [withField fromOption Remote.byName $ \from ->
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
start from file (key, _) = autoCopiesWith file key (>) $ \numcopies ->
stopUnless (checkAuto $ wantDrop (Remote.uuid <$> from) (Just file)) $
stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just file)) $
case from of
Nothing -> startLocal file numcopies key Nothing
Just remote -> do

View file

@ -24,8 +24,8 @@ seek = [withField Command.Move.fromOption Remote.byName $ \from ->
withFilesInGit $ whenAnnexed $ start from]
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
start from file (key, _) = stopUnless ((not <$> inAnnex key) <&&> checkAuto (wantGet $ Just file)) $
autoCopies file key (<) $
start from file (key, _) = stopUnless (not <$> inAnnex key) $
stopUnless (checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just file))) $ do
case from of
Nothing -> go $ perform key file
Just src ->

View file

@ -34,7 +34,7 @@ type AssumeNotPresent = S.Set UUID
{- Checks if there are user-specified limits. -}
limited :: Annex Bool
limited = (not . Utility.Matcher.matchesAny) <$> getMatcher'
limited = (not . Utility.Matcher.isEmpty) <$> getMatcher'
{- Gets a matcher for the user-specified limits. The matcher is cached for
- speed; once it's obtained the user-specified limits can't change. -}

View file

@ -48,8 +48,8 @@ preferredContentSet NoUUID _ = error "unknown UUID; cannot modify"
{- Checks if a file is preferred content for the specified repository
- (or the current repository if none is specified). -}
isPreferredContent :: Maybe UUID -> AssumeNotPresent -> FilePath -> Annex Bool
isPreferredContent mu notpresent file = do
isPreferredContent :: Maybe UUID -> AssumeNotPresent -> FilePath -> Bool -> Annex Bool
isPreferredContent mu notpresent file def = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
let fi = Annex.FileInfo
{ Annex.matchFile = matchfile
@ -58,9 +58,11 @@ isPreferredContent mu notpresent file = do
u <- maybe getUUID return mu
m <- preferredContentMap
case M.lookup u m of
Nothing -> return True
Just matcher -> Utility.Matcher.matchMrun matcher $ \a ->
a notpresent fi
Nothing -> return def
Just matcher
| Utility.Matcher.isEmpty matcher -> return def
| otherwise -> Utility.Matcher.matchMrun matcher $
\a -> a notpresent fi
{- The map is cached for speed. -}
preferredContentMap :: Annex Annex.PreferredContentMap

View file

@ -26,7 +26,7 @@ module Utility.Matcher (
match,
matchM,
matchMrun,
matchesAny
isEmpty
) where
import Common
@ -105,9 +105,7 @@ matchMrun m run = go m
go (MNot m1) = liftM not (go m1)
go (MOp o) = run o
{- Checks is a matcher contains no limits, and so (presumably) matches
- anything. Note that this only checks the trivial case; it is possible
- to construct matchers that match anything but are more complicated. -}
matchesAny :: Matcher a -> Bool
matchesAny MAny = True
matchesAny _ = False
{- Checks if a matcher contains no limits. -}
isEmpty :: Matcher a -> Bool
isEmpty MAny = True
isEmpty _ = False

4
debian/changelog vendored
View file

@ -22,6 +22,10 @@ git-annex (3.20121128) UNRELEASED; urgency=low
* webapp: Encryption can be disabled when setting up remotes.
* assistant: Avoid trying to drop content from remotes that don't have it.
* assistant: Allow periods in ssh key comments.
* get/copy --auto: Transfer data even if it would exceed numcopies,
when preferred content settings want it.
* drop --auto: Fix dropping content when there are no preferred content
settings.
-- Joey Hess <joeyh@debian.org> Wed, 28 Nov 2012 13:31:07 -0400