summaryrefslogtreecommitdiff
path: root/Command/Vicfg.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-03-15 16:17:01 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-03-15 16:17:01 -0400
commit3901089cec96419ab13fe05d4fbc3f040d018672 (patch)
treecf16927c3a17d42c05ccab9545557f2d33996255 /Command/Vicfg.hs
parentfba52e2651cb8b2f26cdb4f38396cd9f55cf0985 (diff)
vicfg: Allows editing preferred content expressions for groups.
This is stored in the git-annex branch, but not yet actually hooked up and used.
Diffstat (limited to 'Command/Vicfg.hs')
-rw-r--r--Command/Vicfg.hs140
1 files changed, 95 insertions, 45 deletions
diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs
index 7608959c2..94fc36184 100644
--- a/Command/Vicfg.hs
+++ b/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
- mapM_ (uncurry trustSet) $ M.toList trustchanges
- mapM_ (uncurry groupSet) $ M.toList groupchanges
- mapM_ (uncurry preferredContentSet) $ M.toList preferredcontentchanges
- mapM_ (uncurry scheduleSet) $ M.toList schedulechanges
-
-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)
+ 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 -> 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"
+ preferredcontent = settings cfg descs cfgPreferredContentMap
+ [ com "Repository preferred contents" ]
+ (\(s, u) -> line "wanted" u s)
+ (\u -> line "wanted" u "standard")
+
+ grouppreferredcontent = settings' cfg allgroups cfgGroupPreferredContentMap
+ [ com "Group preferred contents"
+ , com "(Used by repositories with \"groupwanted\" in their preferred contents)"
]
- (\(s, u) -> line "content" u s)
- (\u -> line "content" u "")
+ (\(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]
- schedule = settings cfgScheduleMap
- [ ""
- , com "Scheduled activities"
+ 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