added preferred-content log, and allow editing it with vicfg
This includes a full parser for the boolean expressions in the log, that compiles them into Matchers. Those matchers are not used yet. A complication is that matching against an expression should never crash git-annex with an error. Instead, vicfg checks that the expressions parse. If a bad expression (or an expression understood by some future git-annex version) gets into the log, it'll be ignored. Most of the code in Limit couldn't fail anyway, but I did have to make limitCopies check its parameter first, and return an error if it's bad, rather than erroring at runtime.
This commit is contained in:
parent
c809f3d486
commit
bc649a35ba
9 changed files with 193 additions and 33 deletions
6
Annex.hs
6
Annex.hs
|
@ -10,6 +10,7 @@
|
|||
module Annex (
|
||||
Annex,
|
||||
AnnexState(..),
|
||||
PreferredContentMap,
|
||||
new,
|
||||
newState,
|
||||
run,
|
||||
|
@ -47,6 +48,7 @@ import Types.BranchState
|
|||
import Types.TrustLevel
|
||||
import Types.Group
|
||||
import Types.Messages
|
||||
import Types.UUID
|
||||
import Utility.State
|
||||
import qualified Utility.Matcher
|
||||
import qualified Data.Map as M
|
||||
|
@ -74,6 +76,8 @@ 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 (FilePath -> Annex Bool))
|
||||
|
||||
-- internal state storage
|
||||
data AnnexState = AnnexState
|
||||
{ repo :: Git.Repo
|
||||
|
@ -90,6 +94,7 @@ data AnnexState = AnnexState
|
|||
, forcebackend :: Maybe String
|
||||
, forcenumcopies :: Maybe Int
|
||||
, limit :: Matcher (FilePath -> Annex Bool)
|
||||
, preferredcontentmap :: Maybe PreferredContentMap
|
||||
, shared :: Maybe SharedRepository
|
||||
, forcetrust :: TrustMap
|
||||
, trustmap :: Maybe TrustMap
|
||||
|
@ -117,6 +122,7 @@ newState gitrepo = AnnexState
|
|||
, forcebackend = Nothing
|
||||
, forcenumcopies = Nothing
|
||||
, limit = Left []
|
||||
, preferredcontentmap = Nothing
|
||||
, shared = Nothing
|
||||
, forcetrust = M.empty
|
||||
, trustmap = Nothing
|
||||
|
|
|
@ -20,6 +20,7 @@ import Types.TrustLevel
|
|||
import Types.Group
|
||||
import Logs.Trust
|
||||
import Logs.Group
|
||||
import Logs.PreferredContent
|
||||
import Remote
|
||||
|
||||
def :: [Command]
|
||||
|
@ -55,6 +56,7 @@ vicfg curcfg f = do
|
|||
data Cfg = Cfg
|
||||
{ cfgTrustMap :: TrustMap
|
||||
, cfgGroupMap :: M.Map UUID (S.Set Group)
|
||||
, cfgPreferredContentMap :: M.Map UUID String
|
||||
, cfgDescriptions :: M.Map UUID String
|
||||
}
|
||||
|
||||
|
@ -62,26 +64,29 @@ getCfg :: Annex Cfg
|
|||
getCfg = Cfg
|
||||
<$> trustMapRaw -- without local trust overrides
|
||||
<*> (groupsByUUID <$> groupMap)
|
||||
<*> preferredContentMapRaw
|
||||
<*> uuidDescriptions
|
||||
|
||||
emptyCfg :: Cfg
|
||||
emptyCfg = Cfg M.empty M.empty M.empty
|
||||
|
||||
setCfg :: Cfg -> Cfg -> Annex ()
|
||||
setCfg curcfg newcfg = do
|
||||
let (trustchanges, groupchanges) = diffCfg curcfg newcfg
|
||||
mapM_ (\(u,t) -> trustSet u t) $ M.toList trustchanges
|
||||
mapM_ (\(u, gs) -> groupChange u $ const gs) $ M.toList groupchanges
|
||||
let (trustchanges, groupchanges, preferredcontentchanges) = diffCfg curcfg newcfg
|
||||
mapM_ (uncurry trustSet) $ M.toList trustchanges
|
||||
mapM_ (uncurry groupSet) $ M.toList groupchanges
|
||||
mapM_ (uncurry preferredContentSet) $ M.toList preferredcontentchanges
|
||||
|
||||
diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group))
|
||||
diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap)
|
||||
diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String)
|
||||
diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap)
|
||||
where
|
||||
diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
|
||||
(f newcfg) (f curcfg)
|
||||
|
||||
genCfg :: Cfg -> String
|
||||
genCfg cfg = unlines $ concat
|
||||
[intro, trustintro, trust, defaulttrust, groupsintro, groups, defaultgroups]
|
||||
[ intro
|
||||
, trustintro, trust, defaulttrust
|
||||
, groupsintro, groups, defaultgroups
|
||||
, preferredcontentintro, preferredcontent, defaultpreferredcontent
|
||||
]
|
||||
where
|
||||
intro =
|
||||
[ com "git-annex configuration"
|
||||
|
@ -91,6 +96,7 @@ genCfg cfg = unlines $ concat
|
|||
, com "Lines in this file have the format:"
|
||||
, com " setting repo = value"
|
||||
]
|
||||
|
||||
trustintro =
|
||||
[ ""
|
||||
, com "Repository trust configuration"
|
||||
|
@ -100,6 +106,7 @@ genCfg cfg = unlines $ concat
|
|||
]
|
||||
trust = map (\(t, u) -> line "trust" u $ showTrustLevel t) $
|
||||
sort $ map swap $ M.toList $ cfgTrustMap cfg
|
||||
|
||||
defaulttrust = map (\u -> pcom $ line "trust" u $ showTrustLevel SemiTrusted) $
|
||||
missing cfgTrustMap
|
||||
groupsintro =
|
||||
|
@ -112,6 +119,15 @@ genCfg cfg = unlines $ concat
|
|||
defaultgroups = map (\u -> pcom $ line "group" u "") $
|
||||
missing cfgGroupMap
|
||||
|
||||
preferredcontentintro =
|
||||
[ ""
|
||||
, com "Repository preferred contents"
|
||||
]
|
||||
preferredcontent = sort $ map (\(s, u) -> line "preferred-content" u s) $
|
||||
map swap $ M.toList $ cfgPreferredContentMap cfg
|
||||
defaultpreferredcontent = map (\u -> pcom $ line "preferred-content" u "") $
|
||||
missing cfgPreferredContentMap
|
||||
|
||||
line setting u value = unwords
|
||||
[ setting
|
||||
, showu u
|
||||
|
@ -160,6 +176,12 @@ parseCfg curcfg = go [] curcfg . lines
|
|||
| setting == "group" =
|
||||
let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)
|
||||
in Right $ cfg { cfgGroupMap = m }
|
||||
| setting == "preferred-content" =
|
||||
case checkPreferredContentExpression value of
|
||||
Just e -> Left e
|
||||
Nothing ->
|
||||
let m = M.insert u value (cfgPreferredContentMap cfg)
|
||||
in Right $ cfg { cfgPreferredContentMap = m }
|
||||
| otherwise = badval "setting" setting
|
||||
|
||||
name2uuid = M.fromList $ map swap $
|
||||
|
|
56
Limit.hs
56
Limit.hs
|
@ -1,6 +1,6 @@
|
|||
{- user-specified limits on files to act on
|
||||
-
|
||||
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2011,2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
@ -24,6 +24,7 @@ import Logs.Group
|
|||
import Utility.HumanTime
|
||||
|
||||
type Limit = Utility.Matcher.Token (FilePath -> Annex Bool)
|
||||
type MkLimit = String -> Either String (FilePath -> Annex Bool)
|
||||
|
||||
{- Checks if there are user-specified limits. -}
|
||||
limited :: Annex Bool
|
||||
|
@ -56,16 +57,22 @@ addToken :: String -> Annex ()
|
|||
addToken = add . Utility.Matcher.token
|
||||
|
||||
{- Adds a new limit. -}
|
||||
addLimit :: (FilePath -> Annex Bool) -> Annex ()
|
||||
addLimit = add . Utility.Matcher.Operation
|
||||
addLimit :: Either String (FilePath -> Annex Bool) -> Annex ()
|
||||
addLimit = either error (add . Utility.Matcher.Operation)
|
||||
|
||||
{- Add a limit to skip files that do not match the glob. -}
|
||||
addInclude :: String -> Annex ()
|
||||
addInclude glob = addLimit $ return . matchglob glob
|
||||
addInclude = addLimit . limitInclude
|
||||
|
||||
limitInclude :: MkLimit
|
||||
limitInclude glob = Right $ return . matchglob glob
|
||||
|
||||
{- Add a limit to skip files that match the glob. -}
|
||||
addExclude :: String -> Annex ()
|
||||
addExclude glob = addLimit $ return . not . matchglob glob
|
||||
addExclude = addLimit . limitExclude
|
||||
|
||||
limitExclude :: MkLimit
|
||||
limitExclude glob = Right $ return . not . matchglob glob
|
||||
|
||||
matchglob :: String -> FilePath -> Bool
|
||||
matchglob glob f = isJust $ match cregex f []
|
||||
|
@ -76,7 +83,10 @@ matchglob glob f = isJust $ match cregex f []
|
|||
{- Adds a limit to skip files not believed to be present
|
||||
- in a specfied repository. -}
|
||||
addIn :: String -> Annex ()
|
||||
addIn name = addLimit $ check $ if name == "." then inAnnex else inremote
|
||||
addIn = addLimit . limitIn
|
||||
|
||||
limitIn :: MkLimit
|
||||
limitIn name = Right $ check $ if name == "." then inAnnex else inremote
|
||||
where
|
||||
check a = Backend.lookupFile >=> handle a
|
||||
handle _ Nothing = return False
|
||||
|
@ -89,18 +99,22 @@ addIn name = addLimit $ check $ if name == "." then inAnnex else inremote
|
|||
{- Adds a limit to skip files not believed to have the specified number
|
||||
- of copies. -}
|
||||
addCopies :: String -> Annex ()
|
||||
addCopies want = addLimit . check $ readnum num
|
||||
addCopies = addLimit . limitCopies
|
||||
|
||||
limitCopies :: MkLimit
|
||||
limitCopies want = case split ":" want of
|
||||
[v, n] -> case readTrustLevel v of
|
||||
Just trust -> go n $ checktrust trust
|
||||
Nothing -> go n $ checkgroup v
|
||||
[n] -> go n $ const $ return True
|
||||
_ -> Left "bad value for copies"
|
||||
where
|
||||
(num, good) = case split ":" want of
|
||||
[v, n] -> case readTrustLevel v of
|
||||
Just trust -> (n, checktrust trust)
|
||||
Nothing -> (n, checkgroup v)
|
||||
[n] -> (n, const $ return True)
|
||||
_ -> error "bad value for --copies"
|
||||
readnum = maybe (error "bad number for --copies") id . readish
|
||||
check n = Backend.lookupFile >=> handle n
|
||||
handle _ Nothing = return False
|
||||
handle n (Just (key, _)) = do
|
||||
go num good = case readish num of
|
||||
Nothing -> Left "bad number for copies"
|
||||
Just n -> Right $ check n good
|
||||
check n good = Backend.lookupFile >=> handle n good
|
||||
handle _ _ Nothing = return False
|
||||
handle n good (Just (key, _)) = do
|
||||
us <- filterM good =<< Remote.keyLocations key
|
||||
return $ length us >= n
|
||||
checktrust t u = (== t) <$> lookupTrust u
|
||||
|
@ -108,7 +122,10 @@ addCopies want = addLimit . check $ readnum num
|
|||
|
||||
{- Adds a limit to skip files not using a specified key-value backend. -}
|
||||
addInBackend :: String -> Annex ()
|
||||
addInBackend name = addLimit $ Backend.lookupFile >=> check
|
||||
addInBackend = addLimit . limitInBackend
|
||||
|
||||
limitInBackend :: MkLimit
|
||||
limitInBackend name = Right $ Backend.lookupFile >=> check
|
||||
where
|
||||
wanted = Backend.lookupBackendName name
|
||||
check = return . maybe False ((==) wanted . snd)
|
||||
|
@ -118,11 +135,10 @@ addTimeLimit s = do
|
|||
let seconds = fromMaybe (error "bad time-limit") $ parseDuration s
|
||||
start <- liftIO getPOSIXTime
|
||||
let cutoff = start + seconds
|
||||
addLimit $ const $ do
|
||||
addLimit $ Right $ const $ do
|
||||
now <- liftIO getPOSIXTime
|
||||
if now > cutoff
|
||||
then do
|
||||
warning $ "Time limit (" ++ s ++ ") reached!"
|
||||
liftIO $ exitWith $ ExitFailure 101
|
||||
else return True
|
||||
|
||||
|
|
|
@ -7,6 +7,7 @@
|
|||
|
||||
module Logs.Group (
|
||||
groupChange,
|
||||
groupSet,
|
||||
lookupGroups,
|
||||
groupMap,
|
||||
) where
|
||||
|
@ -39,7 +40,10 @@ groupChange uuid@(UUID _) modifier = do
|
|||
changeLog ts uuid (modifier curr) .
|
||||
parseLog (Just . S.fromList . words)
|
||||
Annex.changeState $ \s -> s { Annex.groupmap = Nothing }
|
||||
groupChange NoUUID _ = error "unknown UUID; cannot modify group"
|
||||
groupChange NoUUID _ = error "unknown UUID; cannot modify"
|
||||
|
||||
groupSet :: UUID -> S.Set Group -> Annex ()
|
||||
groupSet u g = groupChange u (const g)
|
||||
|
||||
{- Read the groupLog into a map. The map is cached for speed. -}
|
||||
groupMap :: Annex GroupMap
|
||||
|
|
93
Logs/PreferredContent.hs
Normal file
93
Logs/PreferredContent.hs
Normal file
|
@ -0,0 +1,93 @@
|
|||
{- git-annex preferred content matcher configuration
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Logs.PreferredContent (
|
||||
preferredContentSet,
|
||||
preferredContentMap,
|
||||
preferredContentMapRaw,
|
||||
checkPreferredContentExpression,
|
||||
) where
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Data.Either
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Common.Annex
|
||||
import qualified Annex.Branch
|
||||
import qualified Annex
|
||||
import Logs.UUIDBased
|
||||
import Limit (limitInclude, limitExclude, limitIn, limitCopies, limitInBackend)
|
||||
import qualified Utility.Matcher
|
||||
|
||||
{- Filename of preferred-content.log. -}
|
||||
preferredContentLog :: FilePath
|
||||
preferredContentLog = "preferred-content.log"
|
||||
|
||||
{- Changes the preferred content configuration of a remote. -}
|
||||
preferredContentSet :: UUID -> String -> Annex ()
|
||||
preferredContentSet uuid@(UUID _) val = do
|
||||
ts <- liftIO getPOSIXTime
|
||||
Annex.Branch.change preferredContentLog $
|
||||
showLog id . changeLog ts uuid val . parseLog Just
|
||||
Annex.changeState $ \s -> s { Annex.groupmap = Nothing }
|
||||
preferredContentSet NoUUID _ = error "unknown UUID; cannot modify"
|
||||
|
||||
{- Read the preferredContentLog into a map. The map is cached for speed. -}
|
||||
preferredContentMap :: Annex Annex.PreferredContentMap
|
||||
preferredContentMap = do
|
||||
cached <- Annex.getState Annex.preferredcontentmap
|
||||
case cached of
|
||||
Just m -> return m
|
||||
Nothing -> do
|
||||
m <- simpleMap . parseLog (Just . makeMatcher)
|
||||
<$> Annex.Branch.get preferredContentLog
|
||||
Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m }
|
||||
return m
|
||||
|
||||
preferredContentMapRaw :: Annex (M.Map UUID String)
|
||||
preferredContentMapRaw = simpleMap . parseLog Just
|
||||
<$> Annex.Branch.get preferredContentLog
|
||||
|
||||
{- This intentionally never fails, even on unparsable expressions,
|
||||
- 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 :: String -> Utility.Matcher.Matcher (FilePath -> Annex Bool)
|
||||
makeMatcher s
|
||||
| null (lefts tokens) = Utility.Matcher.generate $ rights tokens
|
||||
| otherwise = Utility.Matcher.generate []
|
||||
where
|
||||
tokens = map parseToken $ tokenizeMatcher s
|
||||
|
||||
{- Checks if an expression can be parsed, if not returns Just error -}
|
||||
checkPreferredContentExpression :: String -> Maybe String
|
||||
checkPreferredContentExpression s = case lefts $ map parseToken $ tokenizeMatcher s of
|
||||
[] -> Nothing
|
||||
l -> Just $ unwords $ map ("Parse failure: " ++) l
|
||||
|
||||
parseToken :: String -> Either String (Utility.Matcher.Token (FilePath -> Annex Bool))
|
||||
parseToken t
|
||||
| any (== t) Utility.Matcher.tokens = Right $ Utility.Matcher.token t
|
||||
| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k m
|
||||
where
|
||||
(k, v) = separate (== '=') t
|
||||
m = M.fromList
|
||||
[ ("include", limitInclude)
|
||||
, ("exclude", limitExclude)
|
||||
, ("in", limitIn)
|
||||
, ("copies", limitCopies)
|
||||
, ("backend", limitInBackend)
|
||||
]
|
||||
use a = Utility.Matcher.Operation <$> a v
|
||||
|
||||
{- 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` "()")
|
|
@ -46,7 +46,7 @@ trustSet uuid@(UUID _) level = do
|
|||
changeLog ts uuid level .
|
||||
parseLog (Just . parseTrustLog)
|
||||
Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
|
||||
trustSet NoUUID _ = error "unknown UUID; cannot modify trust level"
|
||||
trustSet NoUUID _ = error "unknown UUID; cannot modify"
|
||||
|
||||
{- Returns the TrustLevel of a given repo UUID. -}
|
||||
lookupTrust :: UUID -> Annex TrustLevel
|
||||
|
|
|
@ -19,6 +19,7 @@ module Utility.Matcher (
|
|||
Token(..),
|
||||
Matcher,
|
||||
token,
|
||||
tokens,
|
||||
generate,
|
||||
match,
|
||||
matchM,
|
||||
|
@ -48,6 +49,9 @@ token "(" = Open
|
|||
token ")" = Close
|
||||
token t = error $ "unknown token " ++ t
|
||||
|
||||
tokens :: [String]
|
||||
tokens = words "and or not ( )"
|
||||
|
||||
{- Converts a list of Tokens into a Matcher. -}
|
||||
generate :: [Token op] -> Matcher op
|
||||
generate = go MAny
|
||||
|
|
|
@ -42,11 +42,15 @@ firstLine = takeWhile (/= '\n')
|
|||
{- Splits a list into segments that are delimited by items matching
|
||||
- a predicate. (The delimiters are not included in the segments.) -}
|
||||
segment :: (a -> Bool) -> [a] -> [[a]]
|
||||
segment p l = map reverse $ go [] [] l
|
||||
segment p = filter (not . all p) . segmentDelim p
|
||||
|
||||
{- Includes the delimiters as segments of their own. -}
|
||||
segmentDelim :: (a -> Bool) -> [a] -> [[a]]
|
||||
segmentDelim p l = map reverse $ go [] [] l
|
||||
where
|
||||
go c r [] = reverse $ c:r
|
||||
go c r (i:is)
|
||||
| p i = go [] (c:r) is
|
||||
| p i = go [] ([i]:c:r) is
|
||||
| otherwise = go (i:c) r is
|
||||
|
||||
{- Given two orderings, returns the second if the first is EQ and returns
|
||||
|
|
|
@ -75,6 +75,17 @@ The file format is one line per repository, with the uuid followed by a space,
|
|||
and then a space-separated list of groups this repository is part of,
|
||||
and finally a timestamp.
|
||||
|
||||
## `preferred-content.log`
|
||||
|
||||
Used to indicate which repositories prefer to contain which file contents.
|
||||
|
||||
The file format is one line per repository, with the uuid followed by a space,
|
||||
then a boolean expression, and finally a timestamp.
|
||||
|
||||
Files matching the expression are preferred to be retained in the
|
||||
repository, while files not matching it are preferred to be stored
|
||||
somewhere else.
|
||||
|
||||
## `aaa/bbb/*.log`
|
||||
|
||||
These log files record [[location_tracking]] information
|
||||
|
|
Loading…
Reference in a new issue