Preferred content path matching bugfix.

When in a subdir, both the normal filepath, and the filepath relative to
the top of the git repo are needed for matching. The former for key lookup,
and the latter for include/exclude to match against. Previously, key lookup
didn't work in this situation.

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

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

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

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

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

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 <joeyh@debian.org>  Wed, 17 Oct 2012 14:24:10 -0400