diff options
| -rw-r--r-- | Annex/Wanted.hs | 20 | ||||
| -rw-r--r-- | Assistant/Drop.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 4 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 4 | ||||
| -rw-r--r-- | Command.hs | 19 | ||||
| -rw-r--r-- | Command/Copy.hs | 13 | ||||
| -rw-r--r-- | Command/Drop.hs | 2 | ||||
| -rw-r--r-- | Command/Get.hs | 4 | ||||
| -rw-r--r-- | Limit.hs | 2 | ||||
| -rw-r--r-- | Logs/PreferredContent.hs | 12 | ||||
| -rw-r--r-- | Utility/Matcher.hs | 12 | ||||
| -rw-r--r-- | debian/changelog | 4 |
12 files changed, 50 insertions, 48 deletions
diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs index 1d98cc0c2..2500f80d1 100644 --- a/Annex/Wanted.hs +++ b/Annex/Wanted.hs @@ -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 diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index 8098300ae..4dd13f2fa 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -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 diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index da3f0608f..9b863d306 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -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) diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 4d46b0920..66d761f6e 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -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 diff --git a/Command.hs b/Command.hs index c095a4fb1..478dfdc39 100644 --- a/Command.hs +++ b/Command.hs @@ -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 diff --git a/Command/Copy.hs b/Command/Copy.hs index dd5599264..6967c2f93 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -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) + diff --git a/Command/Drop.hs b/Command/Drop.hs index e7b52124f..a9eec7825 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -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 diff --git a/Command/Get.hs b/Command/Get.hs index 7f02e7935..1295cdeeb 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -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 -> @@ -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. -} diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index ddcc2acf8..e0eb140b1 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -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 diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index edb4cadd6..3d525e2af 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -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 diff --git a/debian/changelog b/debian/changelog index 39063d991..d41e9e88d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -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 |