add AssumeNotPresent parameter to limits

Solves the issue with preferred content expressions and dropping that
I mentioned yesterday. My solution was to add a parameter to specify a set
of repositories where content should be assumed not to be present. When
deciding whether to drop, it can put the current repository in, and then
if the expression fails to match, the content can be dropped.

Using yesterday's example "(not copies=trusted:2) and (not in=usbdrive)",
when the local repo is one of the 2 trusted copies, the drop check will
see only 1 trusted copy, so the expression matches, and so the content will
not be dropped.
This commit is contained in:
Joey Hess 2012-10-05 16:52:44 -04:00
parent 51f41bad63
commit 7bb4d507ba
3 changed files with 35 additions and 21 deletions

View file

@ -52,6 +52,7 @@ import Types.UUID
import Utility.State import Utility.State
import qualified Utility.Matcher import qualified Utility.Matcher
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S
-- git-annex's monad -- git-annex's monad
newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a } newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
@ -76,7 +77,7 @@ instance MonadBaseControl IO Annex where
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a) type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (FilePath -> Annex Bool)) type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FilePath -> Annex Bool))
-- internal state storage -- internal state storage
data AnnexState = AnnexState data AnnexState = AnnexState

View file

@ -18,13 +18,15 @@ import qualified Utility.Matcher
import qualified Remote import qualified Remote
import qualified Backend import qualified Backend
import Annex.Content import Annex.Content
import Annex.UUID
import Logs.Trust import Logs.Trust
import Types.TrustLevel import Types.TrustLevel
import Logs.Group import Logs.Group
import Utility.HumanTime import Utility.HumanTime
type Limit = Utility.Matcher.Token (FilePath -> Annex Bool) type MatchFiles = AssumeNotPresent -> FilePath -> Annex Bool
type MkLimit = String -> Either String (FilePath -> Annex Bool) type MkLimit = String -> Either String MatchFiles
type AssumeNotPresent = S.Set UUID
{- Checks if there are user-specified limits. -} {- Checks if there are user-specified limits. -}
limited :: Annex Bool limited :: Annex Bool
@ -46,7 +48,7 @@ getMatcher' = do
return matcher return matcher
{- Adds something to the limit list, which is built up reversed. -} {- Adds something to the limit list, which is built up reversed. -}
add :: Limit -> Annex () add :: Utility.Matcher.Token (FilePath -> Annex Bool) -> Annex ()
add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }
where where
prepend (Left ls) = Left $ l:ls prepend (Left ls) = Left $ l:ls
@ -57,22 +59,22 @@ addToken :: String -> Annex ()
addToken = add . Utility.Matcher.token addToken = add . Utility.Matcher.token
{- Adds a new limit. -} {- Adds a new limit. -}
addLimit :: Either String (FilePath -> Annex Bool) -> Annex () addLimit :: Either String MatchFiles -> Annex ()
addLimit = either error (add . Utility.Matcher.Operation) addLimit = either error (\l -> add $ Utility.Matcher.Operation $ l S.empty)
{- Add a limit to skip files that do not match the glob. -} {- Add a limit to skip files that do not match the glob. -}
addInclude :: String -> Annex () addInclude :: String -> Annex ()
addInclude = addLimit . limitInclude addInclude = addLimit . limitInclude
limitInclude :: MkLimit limitInclude :: MkLimit
limitInclude glob = Right $ return . matchglob glob limitInclude glob = Right $ const $ return . matchglob glob
{- Add a limit to skip files that match the glob. -} {- Add a limit to skip files that match the glob. -}
addExclude :: String -> Annex () addExclude :: String -> Annex ()
addExclude = addLimit . limitExclude addExclude = addLimit . limitExclude
limitExclude :: MkLimit limitExclude :: MkLimit
limitExclude glob = Right $ return . not . matchglob glob limitExclude glob = Right $ const $ return . not . matchglob glob
matchglob :: String -> FilePath -> Bool matchglob :: String -> FilePath -> Bool
matchglob glob f = isJust $ match cregex f [] matchglob glob f = isJust $ match cregex f []
@ -86,15 +88,25 @@ addIn :: String -> Annex ()
addIn = addLimit . limitIn addIn = addLimit . limitIn
limitIn :: MkLimit limitIn :: MkLimit
limitIn name = Right $ check $ if name == "." then inAnnex else inremote limitIn name = Right $ \notpresent -> check $
if name == "."
then inhere notpresent
else inremote notpresent
where where
check a = Backend.lookupFile >=> handle a check a = Backend.lookupFile >=> handle a
handle _ Nothing = return False handle _ Nothing = return False
handle a (Just (key, _)) = a key handle a (Just (key, _)) = a key
inremote key = do inremote notpresent key = do
u <- Remote.nameToUUID name u <- Remote.nameToUUID name
us <- Remote.keyLocations key us <- Remote.keyLocations key
return $ u `elem` us return $ u `elem` us && u `S.notMember` notpresent
inhere notpresent key
| S.null notpresent = inAnnex key
| otherwise = do
u <- getUUID
if u `S.member` notpresent
then return False
else inAnnex key
{- Adds a limit to skip files not believed to have the specified number {- Adds a limit to skip files not believed to have the specified number
- of copies. -} - of copies. -}
@ -111,11 +123,12 @@ limitCopies want = case split ":" want of
where where
go num good = case readish num of go num good = case readish num of
Nothing -> Left "bad number for copies" Nothing -> Left "bad number for copies"
Just n -> Right $ check n good Just n -> Right $ \notpresent ->
check n good = Backend.lookupFile >=> handle n good Backend.lookupFile >=> handle n good notpresent
handle _ _ Nothing = return False handle _ _ _ Nothing = return False
handle n good (Just (key, _)) = do handle n good notpresent (Just (key, _)) = do
us <- filterM good =<< Remote.keyLocations key us <- filter (`S.notMember` notpresent)
<$> (filterM good =<< Remote.keyLocations key)
return $ length us >= n return $ length us >= n
checktrust t u = (== t) <$> lookupTrust u checktrust t u = (== t) <$> lookupTrust u
checkgroup g u = S.member g <$> lookupGroups u checkgroup g u = S.member g <$> lookupGroups u
@ -125,7 +138,7 @@ addInBackend :: String -> Annex ()
addInBackend = addLimit . limitInBackend addInBackend = addLimit . limitInBackend
limitInBackend :: MkLimit limitInBackend :: MkLimit
limitInBackend name = Right $ Backend.lookupFile >=> check limitInBackend name = Right $ const $ Backend.lookupFile >=> check
where where
wanted = Backend.lookupBackendName name wanted = Backend.lookupBackendName name
check = return . maybe False ((==) wanted . snd) check = return . maybe False ((==) wanted . snd)
@ -135,7 +148,7 @@ addTimeLimit s = do
let seconds = fromMaybe (error "bad time-limit") $ parseDuration s let seconds = fromMaybe (error "bad time-limit") $ parseDuration s
start <- liftIO getPOSIXTime start <- liftIO getPOSIXTime
let cutoff = start + seconds let cutoff = start + seconds
addLimit $ Right $ const $ do addLimit $ Right $ const $ const $ do
now <- liftIO getPOSIXTime now <- liftIO getPOSIXTime
if now > cutoff if now > cutoff
then do then do

View file

@ -20,7 +20,7 @@ import Common.Annex
import qualified Annex.Branch import qualified Annex.Branch
import qualified Annex import qualified Annex
import Logs.UUIDBased import Logs.UUIDBased
import Limit (limitInclude, limitExclude, limitIn, limitCopies, limitInBackend) import Limit (MatchFiles, limitInclude, limitExclude, limitIn, limitCopies, limitInBackend)
import qualified Utility.Matcher import qualified Utility.Matcher
{- Filename of preferred-content.log. -} {- Filename of preferred-content.log. -}
@ -56,7 +56,7 @@ preferredContentMapRaw = simpleMap . parseLog Just
- because the configuration is shared amoung repositories and newer - because the configuration is shared amoung repositories and newer
- versions of git-annex may add new features. Instead, parse errors - versions of git-annex may add new features. Instead, parse errors
- result in a Matcher that will always succeed. -} - result in a Matcher that will always succeed. -}
makeMatcher :: String -> Utility.Matcher.Matcher (FilePath -> Annex Bool) makeMatcher :: String -> Utility.Matcher.Matcher MatchFiles
makeMatcher s makeMatcher s
| null (lefts tokens) = Utility.Matcher.generate $ rights tokens | null (lefts tokens) = Utility.Matcher.generate $ rights tokens
| otherwise = Utility.Matcher.generate [] | otherwise = Utility.Matcher.generate []
@ -69,7 +69,7 @@ checkPreferredContentExpression s = case lefts $ map parseToken $ tokenizeMatche
[] -> Nothing [] -> Nothing
l -> Just $ unwords $ map ("Parse failure: " ++) l l -> Just $ unwords $ map ("Parse failure: " ++) l
parseToken :: String -> Either String (Utility.Matcher.Token (FilePath -> Annex Bool)) parseToken :: String -> Either String (Utility.Matcher.Token MatchFiles)
parseToken t parseToken t
| any (== t) Utility.Matcher.tokens = Right $ Utility.Matcher.token t | any (== t) Utility.Matcher.tokens = Right $ Utility.Matcher.token t
| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k m | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k m