From 417aea25bebfccec59cbdc8245f68d9de33a1fab Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 15 Mar 2014 16:17:01 -0400 Subject: [PATCH] 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 | 140 ++++++++++++++++++++++++----------- Logs/PreferredContent.hs | 4 +- Logs/PreferredContent/Raw.hs | 22 +++++- Types/StandardGroups.hs | 5 +- debian/changelog | 1 + doc/git-annex.mdwn | 4 +- 6 files changed, 124 insertions(+), 52 deletions(-) diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 7608959c24..94fc36184f 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012 Joey Hess + - Copyright 2012-2014 Joey Hess - - 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 - mapM_ (uncurry trustSet) $ M.toList trustchanges - mapM_ (uncurry groupSet) $ M.toList groupchanges - mapM_ (uncurry preferredContentSet) $ M.toList preferredcontentchanges - mapM_ (uncurry scheduleSet) $ M.toList schedulechanges + let diff = diffCfg curcfg newcfg + mapM_ (uncurry trustSet) $ M.toList $ cfgTrustMap diff + mapM_ (uncurry groupSet) $ M.toList $ cfgGroupMap diff + mapM_ (uncurry preferredContentSet) $ M.toList $ cfgPreferredContentMap diff + 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 curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap, diff cfgScheduleMap) +diffCfg :: Cfg -> Cfg -> Cfg +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 - [intro, trust, groups, preferredcontent, schedule] +genCfg cfg descs = unlines $ intercalate [""] + [ 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 - [ "" - , com "Repository trust configuration" + trust = settings cfg descs cfgTrustMap + [ 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 - [ "" - , com "Repository groups" + groups = settings cfg descs cfgGroupMap + [ 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 - [ "" - , com "Repository preferred contents" - ] - (\(s, u) -> line "content" u s) - (\u -> line "content" u "") + preferredcontent = settings cfg descs cfgPreferredContentMap + [ com "Repository preferred contents" ] + (\(s, u) -> line "wanted" u s) + (\u -> line "wanted" u "standard") - schedule = settings cfgScheduleMap - [ "" - , com "Scheduled activities" + grouppreferredcontent = settings' cfg allgroups cfgGroupPreferredContentMap + [ com "Group preferred contents" + , 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" - | otherwise = handle cfg (toUUID u) setting value' + | null setting || null f = Left "missing field" + | 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 "Search for \"Parse error\" to find the bad lines." - , com "Either fix the bad lines, or delete them (to discard your changes)." + [ com "** There was a problem parsing your input!" + , com "** Search for \"Parse error\" to find the bad lines." + , 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 diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 2bc5f08d64..93609da5ea 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration - - - Copyright 2012 Joey Hess + - Copyright 2012-2014 Joey Hess - - 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 diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs index 63f6118e42..ce91c2dcdd 100644 --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -1,6 +1,6 @@ {- unparsed preferred content expressions - - - Copyright 2012 Joey Hess + - Copyright 2012-2014 Joey Hess - - 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 diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 2f5cd4b304..63182d2a1a 100644 --- a/Types/StandardGroups.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index c73c83f6e0..797f4d5761 100644 --- a/debian/changelog +++ b/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 Thu, 06 Mar 2014 16:17:01 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 37975c4c90..e73c08ca25 100644 --- a/doc/git-annex.mdwn +++ b/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 - branch. + settings, as well as a few others, and when it exits, stores any changes + made back to the git-annex branch. * `direct`