mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

vicfg: Allows editing preferred content expressions for groups.

Browse source 
This is stored in the git-annex branch, but not yet actually hooked up and
used.
This commit is contained in:
Joey Hess 2014-03-15 16:17:01 -04:00
parent 431d805a96
commit 417aea25be
6 changed files with 124 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

140
Command/Vicfg.hs
View file

@ -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
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

4
Logs/PreferredContent.hs
View file

@ -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

22
Logs/PreferredContent/Raw.hs
View file

@ -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

5
Types/StandardGroups.hs
View file

@ -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

1
debian/changelog vendored
View file

@ -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

4
doc/git-annex.mdwn
View file

@ -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`