standard preferred content settings for client, transfer, backup, and archive repositories

I've designed these to work well together, I hope. If I get it wrong,
I can just change the code in one place, since these expressions
won't be stored in the git-annex branch.

2 files changed, 40 insertions, 11 deletions

diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs
index 1f0c6a6fe..37a1d79e0 100644
--- a/Logs/PreferredContent.hs
+++ b/Logs/PreferredContent.hs
@@ -14,8 +14,10 @@ module Logs.PreferredContent (
 ) where
 
 import qualified Data.Map as M
+import qualified Data.Set as S
 import Data.Either
 import Data.Time.Clock.POSIX
+import Data.Monoid
 
 import Common.Annex
 import qualified Annex.Branch
@@ -61,7 +63,8 @@ preferredContentMap = do
 	case cached of
 		Just m -> return m
 		Nothing -> do
-			m <- simpleMap . parseLog (Just . makeMatcher groupmap)
+			m <- simpleMap
+				. parseLogWithUUID ((Just .) . makeMatcher groupmap)
 				<$> Annex.Branch.get preferredContentLog
 			Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m }
 			return m
@@ -74,17 +77,39 @@ 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 -> String -> Utility.Matcher.Matcher MatchFiles
-makeMatcher groupmap s
-	| null (lefts tokens) =  Utility.Matcher.generate $ rights tokens
- 	| otherwise = Utility.Matcher.generate []
+makeMatcher :: GroupMap -> UUID -> String -> Utility.Matcher.Matcher MatchFiles
+makeMatcher groupmap u s
+	| s == "standard" = standardMatcher groupmap u
+	| null (lefts tokens) = Utility.Matcher.generate $ rights tokens
+ 	| otherwise = matchAll
 	where
 		tokens = map (parseToken groupmap) (tokenizeMatcher s)
 
+matchAll :: Utility.Matcher.Matcher MatchFiles
+matchAll = Utility.Matcher.generate []
+
+{- 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 -> Utility.Matcher.Matcher MatchFiles
+standardMatcher groupmap u =
+	maybe matchAll findmatcher $ u `M.lookup` groupsByUUID groupmap
+	where
+		findmatcher s = case catMaybes $ map standard $ S.toList s of
+			[m] -> makeMatcher groupmap u m
+			_ -> matchAll
+ 		{- See doc/preferred_content.mdwn for explanations
+		 - of these expressions. -}
+		standard "client" = Just "exclude=*/archive/*"
+		standard "transfer" = Just "not inallgroup=client and " <> standard "client"
+		standard "archive" = Just "not copies=archive:1"
+		-- backup preferrs all content
+		standard _ = Nothing
+
 {- Checks if an expression can be parsed, if not returns Just error -}
 checkPreferredContentExpression :: String -> Maybe String
-checkPreferredContentExpression s = 
-	case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of
+checkPreferredContentExpression s
+	| s == "standard" = Nothing
+	| otherwise = case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of
 		[] -> Nothing
 		l -> Just $ unwords $ map ("Parse failure: " ++) l
 
diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs
index 847d49923..674ac2184 100644
--- a/Logs/UUIDBased.hs
+++ b/Logs/UUIDBased.hs
@@ -17,6 +17,7 @@ module Logs.UUIDBased (
 	LogEntry(..),
 	TimeStamp(..),
 	parseLog,
+	parseLogWithUUID,
 	showLog,
 	changeLog,
 	addLog,
@@ -56,15 +57,18 @@ showLog shower = unlines . map showpair . M.toList
 			unwords [fromUUID k, shower v]
 
 parseLog :: (String -> Maybe a) -> String -> Log a
-parseLog parser = M.fromListWith best . mapMaybe parse . lines
+parseLog = parseLogWithUUID . const
+
+parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a
+parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines
 	where
 		parse line
 			| null ws = Nothing
-			| otherwise = parser (unwords info) >>= makepair
+			| otherwise = parser u (unwords info) >>= makepair
 			where
-				makepair v = Just (toUUID u, LogEntry ts v)
+				makepair v = Just (u, LogEntry ts v)
 				ws = words line
-				u = Prelude.head ws
+				u = toUUID $ Prelude.head ws
 				t = Prelude.last ws
 				ts
 					| tskey `isPrefixOf` t =