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.

1 files changed, 93 insertions, 0 deletions

diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs
new file mode 100644
index 000000000..f482ac57b
--- /dev/null
+++ b/Logs/PreferredContent.hs
@@ -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` "()")