diff options
| -rw-r--r-- | Annex/FileMatcher.hs | 26 | ||||
| -rw-r--r-- | Limit.hs | 11 | ||||
| -rw-r--r-- | Logs/PreferredContent.hs | 29 | ||||
| -rw-r--r-- | Types/StandardGroups.hs | 37 | ||||
| -rw-r--r-- | debian/changelog | 5 | ||||
| -rw-r--r-- | doc/preferred_content.mdwn | 23 |
6 files changed, 87 insertions, 44 deletions
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 220fea286..cbf6f873b 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -14,9 +14,11 @@ import Limit import Utility.Matcher import Types.Group import Logs.Group +import Logs.Remote import Annex.UUID import qualified Annex import Git.FilePath +import Types.Remote (RemoteConfig) import Data.Either import qualified Data.Set as S @@ -45,10 +47,22 @@ parsedToMatcher parsed = case partitionEithers parsed of ([], vs) -> Right $ generate vs (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es -parseToken :: MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) -parseToken checkpresent groupmap t +exprParser :: GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)] +exprParser groupmap configmap mu expr = + map parse $ tokenizeMatcher expr + where + parse = parseToken + (limitPresent mu) + (limitInDir preferreddir) + groupmap + preferreddir = fromMaybe "public" $ + M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu + +parseToken :: MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) +parseToken checkpresent checkpreferreddir groupmap t | t `elem` tokens = Right $ token t | t == "present" = use checkpresent + | t == "inpreferreddir" = use checkpreferreddir | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $ M.fromList [ ("include", limitInclude) @@ -78,9 +92,9 @@ largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig where go Nothing = return matchAll go (Just expr) = do - m <- groupMap + gm <- groupMap + rc <- readRemoteLog u <- getUUID - either badexpr return $ parsedToMatcher $ - map (parseToken (limitPresent $ Just u) m) - (tokenizeMatcher expr) + either badexpr return $ + parsedToMatcher $ exprParser gm rc (Just u) expr badexpr e = error $ "bad annex.largefiles configuration: " ++ e @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011,2012 Joey Hess <joey@kitenet.net> + - Copyright 2011-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -88,9 +88,9 @@ limitExclude glob = Right $ const $ return . not . matchglob glob - once. Also, we use regex-TDFA because it's less buggy in its support - of non-unicode characters. -} matchglob :: String -> Annex.FileInfo -> Bool -matchglob glob (Annex.FileInfo { Annex.matchFile = f }) = +matchglob glob fi = case cregex of - Right r -> case execute r f of + Right r -> case execute r (Annex.matchFile fi) of Right (Just _) -> True _ -> False Left _ -> error $ "failed to compile regex: " ++ regex @@ -138,6 +138,11 @@ limitPresent u _ = Right $ const $ check $ \key -> do handle _ Nothing = return False handle a (Just (key, _)) = a key +{- Limit to content that is in a directory, anywhere in the repository tree -} +limitInDir :: FilePath -> MkLimit +limitInDir dir = const $ Right $ const $ \fi -> return $ + any (== dir) $ splitPath $ takeDirectory $ Annex.matchFile fi + {- Adds a limit to skip files not believed to have the specified number - of copies. -} addCopies :: String -> Annex () diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index d980cd373..8005fc0d3 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -30,7 +30,9 @@ import qualified Utility.Matcher import Annex.FileMatcher import Annex.UUID import Types.Group +import Types.Remote (RemoteConfig) import Logs.Group +import Logs.Remote import Types.StandardGroups {- Filename of preferred-content.log. -} @@ -65,8 +67,9 @@ preferredContentMap = maybe preferredContentMapLoad return preferredContentMapLoad :: Annex Annex.PreferredContentMap preferredContentMapLoad = do groupmap <- groupMap + configmap <- readRemoteLog m <- simpleMap - . parseLogWithUUID ((Just .) . makeMatcher groupmap) + . parseLogWithUUID ((Just .) . makeMatcher groupmap configmap) <$> Annex.Branch.get preferredContentLog Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } return m @@ -79,30 +82,30 @@ preferredContentMapRaw = simpleMap . parseLog Just - because the configuration is shared amoung repositories and newer - versions of git-annex may add new features. Instead, parse errors - result in a Matcher that will always succeed. -} -makeMatcher :: GroupMap -> UUID -> String -> FileMatcher -makeMatcher groupmap u s - | s == "standard" = standardMatcher groupmap u +makeMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> String -> FileMatcher +makeMatcher groupmap configmap u expr + | expr == "standard" = standardMatcher groupmap configmap u | null (lefts tokens) = Utility.Matcher.generate $ rights tokens | otherwise = matchAll where - tokens = map (parseToken (limitPresent $ Just u) groupmap) (tokenizeMatcher s) + tokens = exprParser groupmap configmap (Just u) expr {- Standard matchers are pre-defined for some groups. If none is defined, - or a repository is in multiple groups with standard matchers, match all. -} -standardMatcher :: GroupMap -> UUID -> FileMatcher -standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $ - getStandardGroup =<< u `M.lookup` groupsByUUID m +standardMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> FileMatcher +standardMatcher groupmap configmap u = + maybe matchAll (makeMatcher groupmap configmap u . preferredContent) $ + getStandardGroup =<< u `M.lookup` groupsByUUID groupmap {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: String -> Maybe String -checkPreferredContentExpression s - | s == "standard" = Nothing - | otherwise = case parsedToMatcher vs of +checkPreferredContentExpression expr + | expr == "standard" = Nothing + | otherwise = case parsedToMatcher tokens of Left e -> Just e Right _ -> Nothing where - vs = map (parseToken (limitPresent Nothing) emptyGroupMap) - (tokenizeMatcher s) + tokens = exprParser emptyGroupMap M.empty Nothing expr {- Puts a UUID in a standard group, and sets its preferred content to use - the standard expression for that group, unless something is already set. -} diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 055dffe6e..e7764d387 100644 --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -7,6 +7,11 @@ module Types.StandardGroups where +import Types.Remote (RemoteConfig) + +import qualified Data.Map as M +import Data.Maybe + data StandardGroup = ClientGroup | TransferGroup @@ -45,17 +50,25 @@ toStandardGroup "public" = Just PublicGroup toStandardGroup "unwanted" = Just UnwantedGroup toStandardGroup _ = Nothing -descStandardGroup :: StandardGroup -> String -descStandardGroup ClientGroup = "client: a repository on your computer" -descStandardGroup TransferGroup = "transfer: distributes files to clients" -descStandardGroup BackupGroup = "full backup: backs up all files" -descStandardGroup IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere" -descStandardGroup SmallArchiveGroup = "small archive: archives files located in \"archive\" directories" -descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere" -descStandardGroup SourceGroup = "file source: moves files on to other repositories" -descStandardGroup ManualGroup = "manual mode: only stores files you manually choose" -descStandardGroup PublicGroup = "public: only stores files located in \"public\" directories" -descStandardGroup UnwantedGroup = "unwanted: remove content from this repository" +descStandardGroup :: Maybe RemoteConfig -> StandardGroup -> String +descStandardGroup _ ClientGroup = "client: a repository on your computer" +descStandardGroup _ TransferGroup = "transfer: distributes files to clients" +descStandardGroup _ BackupGroup = "full backup: backs up all files" +descStandardGroup _ IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere" +descStandardGroup _ SmallArchiveGroup = "small archive: archives files located in \"archive\" directories" +descStandardGroup _ FullArchiveGroup = "full archive: archives all files not archived elsewhere" +descStandardGroup _ SourceGroup = "file source: moves files on to other repositories" +descStandardGroup _ ManualGroup = "manual mode: only stores files you manually choose" +descStandardGroup _ UnwantedGroup = "unwanted: remove content from this repository" +descStandardGroup c PublicGroup = "public: only stores files located in \"" ++ fromJust (specialDirectory c PublicGroup) ++ "\" directories" + +specialDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath +specialDirectory _ SmallArchiveGroup = Just "archive" +specialDirectory _ FullArchiveGroup = Just "archive" +specialDirectory (Just c) PublicGroup = Just $ + fromMaybe "public" $ M.lookup "preferreddir" c +specialDirectory Nothing PublicGroup = Just "public" +specialDirectory _ _ = Nothing {- See doc/preferred_content.mdwn for explanations of these expressions. -} preferredContent :: StandardGroup -> String @@ -71,7 +84,7 @@ preferredContent SmallArchiveGroup = lastResort $ preferredContent FullArchiveGroup = lastResort notArchived preferredContent SourceGroup = "not (copies=1)" preferredContent ManualGroup = "present and (" ++ preferredContent ClientGroup ++ ")" -preferredContent PublicGroup = "include=*/public/* or include=public/*" +preferredContent PublicGroup = "inpreferreddir" preferredContent UnwantedGroup = "exclude=*" notArchived :: String diff --git a/debian/changelog b/debian/changelog index 322f58023..4dde2760b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -32,11 +32,12 @@ git-annex (4.20130418) UNRELEASED; urgency=low * initremote: If two existing remotes have the same name, prefer the one with a higher trust level. * Add public repository group. + (And inpreferreddir to preferred content expressions.) * webapp: Can now set up Internet Archive repositories. * S3: Dropping content from the Internet Archive doesn't work, but their API indicates it does. Always refuse to drop from there. - * webapp: Display some additional information about a repository on its edit - page. + * webapp: Display some additional information about a repository on + its edit page. * Automatically register public urls for files uploaded to the Internet Archive. diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn index de28d0729..23081fc30 100644 --- a/doc/preferred_content.mdwn +++ b/doc/preferred_content.mdwn @@ -72,14 +72,17 @@ Note that `not present` is a very bad thing to put in a preferred content expression. It'll make it prefer to get content that's not present, and drop content that is present! Don't go there.. -### difference: "inmydir" +### difference: "inpreferreddir" -There's a special "inmydir" keyword you can use in a preferred content -expression of a special remote. This means that the content is preferred -if it's in a directory (located anywhere in the tree) with a special name. +There's a special "inpreferreddir" keyword you can use in a +preferred content expression of a special remote. This means that the +content is preferred if it's in a directory (located anywhere in the tree) +with a special name. The name of the directory can be configured using -`git annex initremote $remote mydir=$dirname` +`git annex initremote $remote preferreddir=$dirname` + +(If no directory name is configured, it uses "public" by default.) ## standard expressions @@ -178,10 +181,14 @@ reached an archive repository. ### public This is used for publishing information to a repository that can be -publically accessed. Only files inside `public` directories will be -stored in a public repository. +publically accessed. Only files in a directory with a particular name +will be published. (The directory can be located anywhere in the +repository.) + +The name of the directory can be configured using +`git annex initremote $remote preferreddir=$dirname` -`include=*/public/* or include=public/*` +`inpreferreddir` ### unwanted |