2013-03-29 20:17:13 +00:00
|
|
|
{- git-annex file matching
|
|
|
|
-
|
2016-02-02 19:18:17 +00:00
|
|
|
- Copyright 2012-2016 Joey Hess <id@joeyh.name>
|
2013-03-29 20:17:13 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2016-02-03 20:29:34 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2016-02-03 18:56:34 +00:00
|
|
|
module Annex.FileMatcher (
|
|
|
|
GetFileMatcher,
|
|
|
|
checkFileMatcher,
|
2018-08-27 18:47:17 +00:00
|
|
|
checkFileMatcher',
|
2016-02-03 18:56:34 +00:00
|
|
|
checkMatcher,
|
|
|
|
matchAll,
|
|
|
|
preferredContentParser,
|
|
|
|
parsedToMatcher,
|
2016-02-03 20:58:36 +00:00
|
|
|
mkLargeFilesParser,
|
2016-02-03 18:56:34 +00:00
|
|
|
largeFilesMatcher,
|
|
|
|
) where
|
2013-03-29 20:17:13 +00:00
|
|
|
|
|
|
|
import qualified Data.Map as M
|
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2013-03-29 20:17:13 +00:00
|
|
|
import Limit
|
|
|
|
import Utility.Matcher
|
|
|
|
import Types.Group
|
|
|
|
import qualified Annex
|
2013-05-25 03:07:26 +00:00
|
|
|
import Types.FileMatcher
|
2013-03-29 20:17:13 +00:00
|
|
|
import Git.FilePath
|
2013-04-26 03:44:55 +00:00
|
|
|
import Types.Remote (RemoteConfig)
|
2016-02-02 19:18:17 +00:00
|
|
|
import Annex.CheckAttr
|
2019-01-23 16:39:02 +00:00
|
|
|
import Annex.Magic
|
2016-02-02 19:18:17 +00:00
|
|
|
import Git.CheckAttr (unspecifiedAttr)
|
2013-03-29 20:17:13 +00:00
|
|
|
|
|
|
|
import Data.Either
|
|
|
|
import qualified Data.Set as S
|
|
|
|
|
2016-02-02 19:18:17 +00:00
|
|
|
type GetFileMatcher = FilePath -> Annex (FileMatcher Annex)
|
|
|
|
|
|
|
|
checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool
|
2018-08-27 18:47:17 +00:00
|
|
|
checkFileMatcher getmatcher file = checkFileMatcher' getmatcher file (return True)
|
|
|
|
|
|
|
|
-- | Allows running an action when no matcher is configured for the file.
|
|
|
|
checkFileMatcher' :: GetFileMatcher -> FilePath -> Annex Bool -> Annex Bool
|
|
|
|
checkFileMatcher' getmatcher file notconfigured = do
|
2016-02-02 19:18:17 +00:00
|
|
|
matcher <- getmatcher file
|
2018-08-27 18:47:17 +00:00
|
|
|
checkMatcher matcher Nothing afile S.empty notconfigured d
|
|
|
|
where
|
|
|
|
afile = AssociatedFile (Just file)
|
|
|
|
-- checkMatcher will never use this, because afile is provided.
|
|
|
|
d = return True
|
2013-03-29 20:17:13 +00:00
|
|
|
|
2018-08-27 18:47:17 +00:00
|
|
|
checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool
|
|
|
|
checkMatcher matcher mkey afile notpresent notconfigured d
|
|
|
|
| isEmpty matcher = notconfigured
|
2014-01-23 20:37:08 +00:00
|
|
|
| otherwise = case (mkey, afile) of
|
2017-03-10 17:12:24 +00:00
|
|
|
(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
(Just key, _) -> go (MatchingKey key afile)
|
2018-08-27 18:47:17 +00:00
|
|
|
_ -> d
|
2014-01-23 20:37:08 +00:00
|
|
|
where
|
|
|
|
go mi = matchMrun matcher $ \a -> a notpresent mi
|
|
|
|
|
|
|
|
fileMatchInfo :: FilePath -> Annex MatchInfo
|
|
|
|
fileMatchInfo file = do
|
|
|
|
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
|
2014-02-11 04:39:50 +00:00
|
|
|
return $ MatchingFile FileInfo
|
2014-01-23 20:37:08 +00:00
|
|
|
{ matchFile = matchfile
|
2015-02-06 20:03:02 +00:00
|
|
|
, currFile = file
|
2014-01-23 20:37:08 +00:00
|
|
|
}
|
2013-03-29 20:17:13 +00:00
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
matchAll :: FileMatcher Annex
|
2013-03-29 20:17:13 +00:00
|
|
|
matchAll = generate []
|
|
|
|
|
2016-02-03 18:56:34 +00:00
|
|
|
parsedToMatcher :: [ParseResult] -> Either String (FileMatcher Annex)
|
2013-03-29 20:17:13 +00:00
|
|
|
parsedToMatcher parsed = case partitionEithers parsed of
|
|
|
|
([], vs) -> Right $ generate vs
|
|
|
|
(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
|
|
|
|
|
2016-02-03 18:56:34 +00:00
|
|
|
data ParseToken
|
|
|
|
= SimpleToken String ParseResult
|
|
|
|
| ValueToken String (String -> ParseResult)
|
2013-04-26 03:44:55 +00:00
|
|
|
|
2016-02-03 18:56:34 +00:00
|
|
|
type ParseResult = Either String (Token (MatchFiles Annex))
|
|
|
|
|
|
|
|
parseToken :: [ParseToken] -> String -> ParseResult
|
|
|
|
parseToken l t
|
2013-04-03 07:52:41 +00:00
|
|
|
| t `elem` tokens = Right $ token t
|
2016-02-03 18:56:34 +00:00
|
|
|
| otherwise = go l
|
2013-03-29 20:17:13 +00:00
|
|
|
where
|
2016-02-03 18:56:34 +00:00
|
|
|
go [] = Left $ "near " ++ show t
|
|
|
|
go (SimpleToken s r : _) | s == t = r
|
|
|
|
go (ValueToken s mkr : _) | s == k = mkr v
|
|
|
|
go (_ : ps) = go ps
|
2013-03-29 20:17:13 +00:00
|
|
|
(k, v) = separate (== '=') t
|
2016-02-03 18:56:34 +00:00
|
|
|
|
|
|
|
commonTokens :: [ParseToken]
|
|
|
|
commonTokens =
|
|
|
|
[ SimpleToken "unused" (simply limitUnused)
|
|
|
|
, SimpleToken "anything" (simply limitAnything)
|
|
|
|
, SimpleToken "nothing" (simply limitNothing)
|
|
|
|
, ValueToken "include" (usev limitInclude)
|
|
|
|
, ValueToken "exclude" (usev limitExclude)
|
|
|
|
, ValueToken "largerthan" (usev $ limitSize (>))
|
|
|
|
, ValueToken "smallerthan" (usev $ limitSize (<))
|
|
|
|
]
|
2013-03-29 20:17:13 +00:00
|
|
|
|
|
|
|
{- This is really dumb tokenization; there's no support for quoted values.
|
|
|
|
- Open and close parens are always treated as standalone tokens;
|
|
|
|
- otherwise tokens must be separated by whitespace. -}
|
|
|
|
tokenizeMatcher :: String -> [String]
|
|
|
|
tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
|
|
|
|
where
|
|
|
|
splitparens = segmentDelim (`elem` "()")
|
|
|
|
|
2016-02-03 18:56:34 +00:00
|
|
|
preferredContentParser :: FileMatcher Annex -> FileMatcher Annex -> Annex GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [ParseResult]
|
|
|
|
preferredContentParser matchstandard matchgroupwanted getgroupmap configmap mu expr =
|
|
|
|
map parse $ tokenizeMatcher expr
|
|
|
|
where
|
|
|
|
parse = parseToken $
|
|
|
|
[ SimpleToken "standard" (call matchstandard)
|
|
|
|
, SimpleToken "groupwanted" (call matchgroupwanted)
|
|
|
|
, SimpleToken "present" (simply $ limitPresent mu)
|
|
|
|
, SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir)
|
2017-02-27 19:02:38 +00:00
|
|
|
, SimpleToken "securehash" (simply limitSecureHash)
|
2016-02-03 18:56:34 +00:00
|
|
|
, ValueToken "copies" (usev limitCopies)
|
|
|
|
, ValueToken "lackingcopies" (usev $ limitLackingCopies False)
|
|
|
|
, ValueToken "approxlackingcopies" (usev $ limitLackingCopies True)
|
|
|
|
, ValueToken "inbacked" (usev limitInBackend)
|
|
|
|
, ValueToken "metadata" (usev limitMetaData)
|
|
|
|
, ValueToken "inallgroup" (usev $ limitInAllGroup getgroupmap)
|
|
|
|
] ++ commonTokens
|
|
|
|
preferreddir = fromMaybe "public" $
|
|
|
|
M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
|
|
|
|
|
2016-02-03 20:29:34 +00:00
|
|
|
mkLargeFilesParser :: Annex (String -> [ParseResult])
|
|
|
|
mkLargeFilesParser = do
|
2019-01-23 16:39:02 +00:00
|
|
|
magicmime <- liftIO initMagicMimeType
|
2016-02-03 20:29:34 +00:00
|
|
|
let parse = parseToken $ commonTokens
|
|
|
|
#ifdef WITH_MAGICMIME
|
|
|
|
++ [ ValueToken "mimetype" (usev $ matchMagic magicmime) ]
|
|
|
|
#else
|
|
|
|
++ [ ValueToken "mimetype" (const $ Left "\"mimetype\" not supported; not built with MagicMime support") ]
|
|
|
|
#endif
|
|
|
|
return $ map parse . tokenizeMatcher
|
2016-02-03 18:56:34 +00:00
|
|
|
|
2013-03-29 20:17:13 +00:00
|
|
|
{- Generates a matcher for files large enough (or meeting other criteria)
|
|
|
|
- to be added to the annex, rather than directly to git. -}
|
2016-02-02 19:18:17 +00:00
|
|
|
largeFilesMatcher :: Annex GetFileMatcher
|
2013-03-29 20:17:13 +00:00
|
|
|
largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
|
|
|
|
where
|
|
|
|
go (Just expr) = do
|
2016-02-02 19:18:17 +00:00
|
|
|
matcher <- mkmatcher expr
|
|
|
|
return $ const $ return matcher
|
|
|
|
go Nothing = return $ \file -> do
|
|
|
|
expr <- checkAttr "annex.largefiles" file
|
|
|
|
if null expr || expr == unspecifiedAttr
|
|
|
|
then return matchAll
|
|
|
|
else mkmatcher expr
|
|
|
|
|
2016-02-03 20:29:34 +00:00
|
|
|
mkmatcher expr = do
|
|
|
|
parser <- mkLargeFilesParser
|
|
|
|
either badexpr return $ parsedToMatcher $ parser expr
|
2016-11-16 01:29:54 +00:00
|
|
|
badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e
|
2016-02-03 18:56:34 +00:00
|
|
|
|
|
|
|
simply :: MatchFiles Annex -> ParseResult
|
|
|
|
simply = Right . Operation
|
|
|
|
|
|
|
|
usev :: MkLimit Annex -> String -> ParseResult
|
|
|
|
usev a v = Operation <$> a v
|
|
|
|
|
|
|
|
call :: FileMatcher Annex -> ParseResult
|
|
|
|
call sub = Right $ Operation $ \notpresent mi ->
|
|
|
|
matchMrun sub $ \a -> a notpresent mi
|