vicfg: Allows editing preferred content expressions for groups.

This is stored in the git-annex branch, but not yet actually hooked up and
used.

Command/Vicfg.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -60,7 +60,8 @@ vicfg curcfg f = do
 data Cfg = Cfg
 	{ cfgTrustMap :: TrustMap
 	, cfgGroupMap :: M.Map UUID (S.Set Group)
-	, cfgPreferredContentMap :: M.Map UUID String
+	, cfgPreferredContentMap :: M.Map UUID PreferredContentExpression
+	, cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression
 	, cfgScheduleMap :: M.Map UUID [ScheduledActivity]
 	}
 
@@ -69,25 +70,40 @@ getCfg = Cfg
 	<$> trustMapRaw -- without local trust overrides
 	<*> (groupsByUUID <$> groupMap)
 	<*> preferredContentMapRaw
+	<*> groupPreferredContentMapRaw
 	<*> scheduleMap
 
 setCfg :: Cfg -> Cfg -> Annex ()
 setCfg curcfg newcfg = do
-	let (trustchanges, groupchanges, preferredcontentchanges, schedulechanges) = diffCfg curcfg newcfg
+	let diff = diffCfg curcfg newcfg
-	mapM_ (uncurry trustSet) $ M.toList trustchanges
+	mapM_ (uncurry trustSet) $ M.toList $ cfgTrustMap diff
-	mapM_ (uncurry groupSet) $ M.toList groupchanges
+	mapM_ (uncurry groupSet) $ M.toList $ cfgGroupMap diff
-	mapM_ (uncurry preferredContentSet) $ M.toList preferredcontentchanges
+	mapM_ (uncurry preferredContentSet) $ M.toList $ cfgPreferredContentMap diff
-	mapM_ (uncurry scheduleSet) $ M.toList schedulechanges
+	mapM_ (uncurry groupPreferredContentSet) $ M.toList $ cfgGroupPreferredContentMap diff
+	mapM_ (uncurry scheduleSet) $ M.toList $ cfgScheduleMap diff
 
-diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String, M.Map UUID [ScheduledActivity])
+diffCfg :: Cfg -> Cfg -> Cfg
-diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap, diff cfgScheduleMap)
+diffCfg curcfg newcfg = Cfg
+	{ cfgTrustMap = diff cfgTrustMap
+	, cfgGroupMap = diff cfgGroupMap
+	, cfgPreferredContentMap = diff cfgPreferredContentMap
+	, cfgGroupPreferredContentMap = diff cfgGroupPreferredContentMap
+	, cfgScheduleMap = diff cfgScheduleMap
+	}
   where
 	diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
 		(f newcfg) (f curcfg)
 
 genCfg :: Cfg -> M.Map UUID String -> String
-genCfg cfg descs = unlines $ concat
+genCfg cfg descs = unlines $ intercalate [""]
-	[intro, trust, groups, preferredcontent, schedule]
+	[ intro
+	, trust
+	, groups
+	, preferredcontent
+	, grouppreferredcontent
+	, standardgroups
+	, schedule
+	]
   where
 	intro =
 		[ com "git-annex configuration"
@@ -95,22 +111,20 @@ genCfg cfg descs = unlines $ concat
 		, com "Changes saved to this file will be recorded in the git-annex branch."
 		, com ""
 		, com "Lines in this file have the format:"
-		, com "  setting uuid = value"
+		, com "  setting field = value"
 		]
 
-	trust = settings cfgTrustMap
+	trust = settings cfg descs cfgTrustMap
-		[ ""
+		[ com "Repository trust configuration"
-		, com "Repository trust configuration"
 		, com "(Valid trust levels: " ++ trustlevels ++ ")"
 		]
 		(\(t, u) -> line "trust" u $ showTrustLevel t)
 		(\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted)
 	  where
-	  	trustlevels = unwords $ map showTrustLevel [Trusted .. DeadTrusted]
+		trustlevels = unwords $ map showTrustLevel [Trusted .. DeadTrusted]
 
-	groups = settings cfgGroupMap
+	groups = settings cfg descs cfgGroupMap
-		[ ""
+		[ com "Repository groups"
-		, com "Repository groups"
 		, com $ "(Standard groups: " ++ grouplist ++ ")"
 		, com "(Separate group names with spaces)"
 		]
@@ -119,33 +133,60 @@ genCfg cfg descs = unlines $ concat
 	  where
 	  	grouplist = unwords $ map fromStandardGroup [minBound..]
 
-	preferredcontent = settings cfgPreferredContentMap
+	preferredcontent = settings cfg descs cfgPreferredContentMap
-		[ ""
+		[ com "Repository preferred contents" ]
-		, com "Repository preferred contents"
+		(\(s, u) -> line "wanted" u s)
-		]
+		(\u -> line "wanted" u "standard")
-		(\(s, u) -> line "content" u s)
-		(\u -> line "content" u "")
 
-	schedule = settings cfgScheduleMap
+	grouppreferredcontent = settings' cfg allgroups cfgGroupPreferredContentMap
-		[ ""
+		[ com "Group preferred contents"
-		, com "Scheduled activities"
+		, com "(Used by repositories with \"groupwanted\" in their preferred contents)"
+		]
+		(\(s, g) -> gline g s)
+		(\g -> gline g "standard")
+	  where
+	  	gline g value = [ unwords ["groupwanted", g, "=", value] ]
+		allgroups = S.unions $ stdgroups : M.elems (cfgGroupMap cfg)
+		stdgroups = S.fromList $ map fromStandardGroup [minBound..maxBound]
+
+	standardgroups =
+		[ com "Standard preferred contents"
+		, com "(Used by wanted or groupwanted expressions containing \"standard\")"
+		, com "(For reference only; built-in and cannot be changed!)"
+		]
+		++ map gline [minBound..maxBound]
+	  where
+		gline g = com $ unwords
+			[ "standard"
+			, fromStandardGroup g, "=", preferredContent g
+			]
+	
+	schedule = settings cfg descs cfgScheduleMap
+		[ com "Scheduled activities"
 		, com "(Separate multiple activities with \"; \")"
 		]
 		(\(l, u) -> line "schedule" u $ fromScheduledActivities l)
 		(\u -> line "schedule" u "")
 
-	settings field desc showvals showdefaults = concat
-		[ desc
-		, concatMap showvals $ sort $ map swap $ M.toList $ field cfg
-		, concatMap (lcom . showdefaults) $ missing field
-		]
-
 	line setting u value =
 		[ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")"
 		, unwords [setting, fromUUID u, "=", value]
 		]
-	lcom = map (\l -> if "#" `isPrefixOf` l then l else '#' : l)
+	
-	missing field = S.toList $ M.keysSet descs `S.difference` M.keysSet (field cfg)
+settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]
+settings cfg descs = settings' cfg (M.keysSet descs)
+
+settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String]
+settings' cfg s field desc showvals showdefaults = concat
+	[ desc
+	, concatMap showvals $ sort $ map swap $ M.toList $ field cfg
+	, concatMap (lcom . showdefaults) missing
+	]
+  where
+	missing = S.toList $ s `S.difference` M.keysSet (field cfg)
+
+lcom :: [String] -> [String]
+lcom = map (\l -> if "#" `isPrefixOf` l then l else '#' : l)
 
 {- If there's a parse error, returns a new version of the file,
  - with the problem lines noted. -}
@@ -163,16 +204,16 @@ parseCfg curcfg = go [] curcfg . lines
 	parse l cfg
 		| null l = Right cfg
 		| "#" `isPrefixOf` l = Right cfg
-		| null setting || null u = Left "missing repository uuid"
+		| null setting || null f = Left "missing field"
-		| otherwise = handle cfg (toUUID u) setting value'
+		| otherwise = handle cfg f setting value'
 	  where
 		(setting, rest) = separate isSpace l
 		(r, value) = separate (== '=') rest
 		value' = trimspace value
-		u = reverse $ trimspace $ reverse $ trimspace r
+		f = reverse $ trimspace $ reverse $ trimspace r
 		trimspace = dropWhile isSpace
 
-	handle cfg u setting value
+	handle cfg f setting value
 		| setting == "trust" = case readTrustLevel value of
 			Nothing -> badval "trust value" value
 			Just t ->
@@ -181,18 +222,26 @@ parseCfg curcfg = go [] curcfg . lines
 		| setting == "group" =
 			let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)
 			in Right $ cfg { cfgGroupMap = m }
-		| setting == "content" = 
+		| setting == "wanted" = 
 			case checkPreferredContentExpression value of
 				Just e -> Left e
 				Nothing ->
 					let m = M.insert u value (cfgPreferredContentMap cfg)
 					in Right $ cfg { cfgPreferredContentMap = m }
+		| setting == "groupwanted" =
+			case checkPreferredContentExpression value of
+				Just e -> Left e
+				Nothing ->
+					let m = M.insert f value (cfgGroupPreferredContentMap cfg)
+					in Right $ cfg { cfgGroupPreferredContentMap = m }
 		| setting == "schedule" = case parseScheduledActivities value of
 			Left e -> Left e
 			Right l -> 
 				let m = M.insert u l (cfgScheduleMap cfg)
 				in Right $ cfg { cfgScheduleMap = m }
 		| otherwise = badval "setting" setting
+	  where
+		u = toUUID f
 
 	showerr (Just msg, l) = [parseerr ++ msg, l]
 	showerr (Nothing, l)
@@ -203,11 +252,12 @@ parseCfg curcfg = go [] curcfg . lines
 
 	badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\""
 	badheader = 
-		[ com "There was a problem parsing your input."
+		[ com "** There was a problem parsing your input!"
-		, com "Search for \"Parse error\" to find the bad lines."
+		, com "** Search for \"Parse error\" to find the bad lines."
-		, com "Either fix the bad lines, or delete them (to discard your changes)."
+		, com "** Either fix the bad lines, or delete them (to discard your changes)."
+		, ""
 		]
-	parseerr = com "Parse error in next line: "
+	parseerr = com "** Parse error in next line: "
 
 com :: String -> String
 com s = "# " ++ s

Logs/PreferredContent.hs

@@ -1,6 +1,6 @@
 {- git-annex preferred content matcher configuration
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -8,10 +8,12 @@
 module Logs.PreferredContent (
 	preferredContentLog,
 	preferredContentSet,
+	groupPreferredContentSet,
 	isPreferredContent,
 	preferredContentMap,
 	preferredContentMapLoad,
 	preferredContentMapRaw,
+	groupPreferredContentMapRaw,
 	checkPreferredContentExpression,
 	setStandardGroup,
 ) where

Logs/PreferredContent/Raw.hs

@@ -1,6 +1,6 @@
 {- unparsed preferred content expressions
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -15,17 +15,35 @@ import qualified Annex.Branch
 import qualified Annex
 import Logs
 import Logs.UUIDBased
+import Logs.MapLog
 import Types.StandardGroups
+import Types.Group
 
 {- Changes the preferred content configuration of a remote. -}
 preferredContentSet :: UUID -> PreferredContentExpression -> Annex ()
 preferredContentSet uuid@(UUID _) val = do
 	ts <- liftIO getPOSIXTime
 	Annex.Branch.change preferredContentLog $
-		showLog id . changeLog ts uuid val . parseLog Just
+		showLog id
+		. changeLog ts uuid val
+		. parseLog Just
 	Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing }
 preferredContentSet NoUUID _ = error "unknown UUID; cannot modify"
 
+{- Changes the preferred content configuration of a group. -}
+groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex ()
+groupPreferredContentSet g val = do
+	ts <- liftIO getPOSIXTime
+	Annex.Branch.change groupPreferredContentLog $
+		showMapLog id id 
+		. changeMapLog ts g val 
+		. parseMapLog Just Just
+	Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing }
+
 preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)
 preferredContentMapRaw = simpleMap . parseLog Just
 	<$> Annex.Branch.get preferredContentLog
+
+groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression)
+groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just
+	<$> Annex.Branch.get groupPreferredContentLog

Types/StandardGroups.hs

@@ -8,6 +8,7 @@
 module Types.StandardGroups where
 
 import Types.Remote (RemoteConfig)
+import Types.Group
 
 import qualified Data.Map as M
 import Data.Maybe
@@ -27,7 +28,7 @@ data StandardGroup
 	| UnwantedGroup
 	deriving (Eq, Ord, Enum, Bounded, Show)
 
-fromStandardGroup :: StandardGroup -> String
+fromStandardGroup :: StandardGroup -> Group
 fromStandardGroup ClientGroup = "client"
 fromStandardGroup TransferGroup = "transfer"
 fromStandardGroup BackupGroup = "backup"
@@ -39,7 +40,7 @@ fromStandardGroup ManualGroup = "manual"
 fromStandardGroup PublicGroup = "public"
 fromStandardGroup UnwantedGroup = "unwanted"
 
-toStandardGroup :: String -> Maybe StandardGroup
+toStandardGroup :: Group -> Maybe StandardGroup
 toStandardGroup "client" = Just ClientGroup
 toStandardGroup "transfer" = Just TransferGroup
 toStandardGroup "backup" = Just BackupGroup

debian/changelog

@@ -20,6 +20,7 @@ git-annex (5.20140307) UNRELEASED; urgency=medium
   * "standard" can now be used as a first-class keyword in preferred content
     expressions. For example "standard or (include=otherdir/*)"
   * Avoid encoding errors when using the unused log file.
+  * vicfg: Allows editing preferred content expressions for groups.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 06 Mar 2014 16:17:01 -0400
 

doc/git-annex.mdwn

@@ -477,8 +477,8 @@ subdirectories).
 * `vicfg`
 
   Opens EDITOR on a temp file containing most of the above configuration
-  settings, and when it exits, stores any changes made back to the git-annex
+  settings, as well as a few others, and when it exits, stores any changes
-  branch.
+  made back to the git-annex branch.
 
 * `direct`