diff --git a/Annex.hs b/Annex.hs index a4a56f5ff3..1cadaed512 100644 --- a/Annex.hs +++ b/Annex.hs @@ -10,6 +10,7 @@ module Annex ( Annex, AnnexState(..), + FileInfo(..), PreferredContentMap, new, newState, @@ -77,7 +78,12 @@ instance MonadBaseControl IO Annex where type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a) -type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FilePath -> Annex Bool)) +data FileInfo = FileInfo + { relFile :: FilePath -- may be relative to cwd + , matchFile :: FilePath -- filepath to match on; may be relative to top + } + +type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FileInfo -> Annex Bool)) -- internal state storage data AnnexState = AnnexState @@ -94,7 +100,7 @@ data AnnexState = AnnexState , checkattrhandle :: Maybe CheckAttrHandle , forcebackend :: Maybe String , forcenumcopies :: Maybe Int - , limit :: Matcher (FilePath -> Annex Bool) + , limit :: Matcher (FileInfo -> Annex Bool) , preferredcontentmap :: Maybe PreferredContentMap , shared :: Maybe SharedRepository , forcetrust :: TrustMap diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs index d7c28efad1..1d98cc0c20 100644 --- a/Annex/Wanted.hs +++ b/Annex/Wanted.hs @@ -9,7 +9,6 @@ module Annex.Wanted where import Common.Annex import Logs.PreferredContent -import Git.FilePath import Annex.UUID import Types.Remote @@ -18,22 +17,17 @@ 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) = do - fp <- inRepo $ toTopFilePath file - isPreferredContent Nothing S.empty fp +wantGet (Just file) = isPreferredContent Nothing S.empty file {- Check if a file is preferred content for a remote. -} wantSend :: AssociatedFile -> UUID -> Annex Bool wantSend Nothing _ = return True -wantSend (Just file) to = do - fp <- inRepo $ toTopFilePath file - isPreferredContent (Just to) S.empty fp +wantSend (Just file) to = isPreferredContent (Just to) S.empty file {- 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 - fp <- inRepo $ toTopFilePath file u <- maybe getUUID (return . id) from - not <$> isPreferredContent (Just u) (S.singleton u) fp + not <$> isPreferredContent (Just u) (S.singleton u) file diff --git a/Limit.hs b/Limit.hs index f39e2d6b8d..cdaadfe2df 100644 --- a/Limit.hs +++ b/Limit.hs @@ -28,7 +28,7 @@ import Logs.Group import Utility.HumanTime import Utility.DataUnits -type MatchFiles = AssumeNotPresent -> FilePath -> Annex Bool +type MatchFiles = AssumeNotPresent -> Annex.FileInfo -> Annex Bool type MkLimit = String -> Either String MatchFiles type AssumeNotPresent = S.Set UUID @@ -38,10 +38,10 @@ limited = (not . Utility.Matcher.matchesAny) <$> 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. -} -getMatcher :: Annex (FilePath -> Annex Bool) +getMatcher :: Annex (Annex.FileInfo -> Annex Bool) getMatcher = Utility.Matcher.matchM <$> getMatcher' -getMatcher' :: Annex (Utility.Matcher.Matcher (FilePath -> Annex Bool)) +getMatcher' :: Annex (Utility.Matcher.Matcher (Annex.FileInfo -> Annex Bool)) getMatcher' = do m <- Annex.getState Annex.limit case m of @@ -52,7 +52,7 @@ getMatcher' = do return matcher {- Adds something to the limit list, which is built up reversed. -} -add :: Utility.Matcher.Token (FilePath -> Annex Bool) -> Annex () +add :: Utility.Matcher.Token (Annex.FileInfo -> Annex Bool) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } where prepend (Left ls) = Left $ l:ls @@ -80,8 +80,9 @@ addExclude = addLimit . limitExclude limitExclude :: MkLimit limitExclude glob = Right $ const $ return . not . matchglob glob -matchglob :: String -> FilePath -> Bool -matchglob glob f = isJust $ match cregex f [] +matchglob :: String -> Annex.FileInfo -> Bool +matchglob glob (Annex.FileInfo { Annex.matchFile = f }) = + isJust $ match cregex f [] where cregex = compile regex [] regex = '^':wildToRegex glob @@ -97,7 +98,7 @@ limitIn name = Right $ \notpresent -> check $ then inhere notpresent else inremote notpresent where - check a = Backend.lookupFile >=> handle a + check a = lookupFile >=> handle a handle _ Nothing = return False handle a (Just (key, _)) = a key inremote notpresent key = do @@ -127,8 +128,8 @@ limitCopies want = case split ":" want of where go num good = case readish num of Nothing -> Left "bad number for copies" - Just n -> Right $ \notpresent -> - Backend.lookupFile >=> handle n good notpresent + Just n -> Right $ \notpresent f -> + lookupFile f >>= handle n good notpresent handle _ _ _ Nothing = return False handle n good notpresent (Just (key, _)) = do us <- filter (`S.notMember` notpresent) @@ -147,8 +148,7 @@ addInAllGroup groupname = do limitInAllGroup :: GroupMap -> MkLimit limitInAllGroup m groupname | S.null want = Right $ const $ const $ return True - | otherwise = Right $ \notpresent -> - Backend.lookupFile >=> check notpresent + | otherwise = Right $ \notpresent -> lookupFile >=> check notpresent where want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m check _ Nothing = return False @@ -164,7 +164,7 @@ addInBackend :: String -> Annex () addInBackend = addLimit . limitInBackend limitInBackend :: MkLimit -limitInBackend name = Right $ const $ Backend.lookupFile >=> check +limitInBackend name = Right $ const $ lookupFile >=> check where wanted = Backend.lookupBackendName name check = return . maybe False ((==) wanted . snd) @@ -179,7 +179,7 @@ addSmallerThan = addLimit . limitSize (<) limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit limitSize vs s = case readSize dataUnits s of Nothing -> Left "bad size" - Just sz -> Right $ const $ Backend.lookupFile >=> check sz + Just sz -> Right $ const $ lookupFile >=> check sz where check _ Nothing = return False check sz (Just (key, _)) = return $ keySize key `vs` Just sz @@ -196,3 +196,6 @@ addTimeLimit s = do warning $ "Time limit (" ++ s ++ ") reached!" liftIO $ exitWith $ ExitFailure 101 else return True + +lookupFile :: Annex.FileInfo -> Annex (Maybe (Key, Backend)) +lookupFile = Backend.lookupFile . Annex.relFile diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 049d6b86b8..d3c120b707 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -46,15 +46,19 @@ 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 -> TopFilePath -> Annex Bool +isPreferredContent :: Maybe UUID -> AssumeNotPresent -> FilePath -> Annex Bool isPreferredContent mu notpresent file = do + matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) + let fi = Annex.FileInfo + { Annex.matchFile = matchfile + , Annex.relFile = file + } 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 (getTopFilePath file) + Just matcher -> Utility.Matcher.matchMrun matcher $ \a -> + a notpresent fi {- Read the preferredContentLog into a map. The map is cached for speed. -} preferredContentMap :: Annex Annex.PreferredContentMap diff --git a/Seek.hs b/Seek.hs index aeaf26bb79..1f18861bcc 100644 --- a/Seek.hs +++ b/Seek.hs @@ -113,7 +113,7 @@ prepFiltered a fs = do map (process matcher) <$> fs where process matcher f = do - ok <- matcher f + ok <- matcher $ Annex.FileInfo f f if ok then a f else return Nothing notSymlink :: FilePath -> IO Bool diff --git a/debian/changelog b/debian/changelog index e6e736c418..7371a351bf 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,7 @@ git-annex (3.20121018) UNRELEASED; urgency=low * Fix handling of GIT_DIR when it refers to a git submodule. + * Preferred content path matching bugfix. -- Joey Hess Wed, 17 Oct 2012 14:24:10 -0400