diff options
| -rw-r--r-- | Assistant/Threads/ConfigMonitor.hs | 7 | ||||
| -rw-r--r-- | Command/Drop.hs | 47 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 2 | ||||
| -rw-r--r-- | Command/Vicfg.hs | 17 | ||||
| -rw-r--r-- | Logs/PreferredContent.hs | 47 | ||||
| -rw-r--r-- | Logs/PreferredContent/Raw.hs | 21 | ||||
| -rw-r--r-- | Utility/Matcher.hs | 2 | ||||
| -rw-r--r-- | debian/changelog | 1 | ||||
| -rw-r--r-- | doc/required_content.mdwn | 17 | ||||
| -rw-r--r-- | doc/todo/required_content.mdwn | 16 |
10 files changed, 140 insertions, 37 deletions
diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index d143c0946..d02e53db5 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -62,16 +62,17 @@ configFilesActions = , (groupLog, void $ liftAnnex groupMapLoad) , (numcopiesLog, void $ liftAnnex globalNumCopiesLoad) , (scheduleLog, void updateScheduleLog) - -- Preferred content settings depend on most of the other configs, - -- so will be reloaded whenever any configs change. + -- Preferred and required content settings depend on most of the + -- other configs, so will be reloaded whenever any configs change. , (preferredContentLog, noop) + , (requiredContentLog, noop) , (groupPreferredContentLog, noop) ] reloadConfigs :: Configs -> Assistant () reloadConfigs changedconfigs = do sequence_ as - void $ liftAnnex preferredContentMapLoad + void $ liftAnnex preferredRequiredMapsLoad {- Changes to the remote log, or the trust log, can affect the - syncRemotes list. Changes to the uuid log may affect its - display so are also included. -} diff --git a/Command/Drop.hs b/Command/Drop.hs index f6c1880e9..269c4c26b 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -14,11 +14,14 @@ import qualified Annex import Annex.UUID import Logs.Location import Logs.Trust +import Logs.PreferredContent import Config.NumCopies import Annex.Content import Annex.Wanted import Annex.Notification +import qualified Data.Set as S + def :: [Command] def = [withOptions [dropFromOption] $ command "drop" paramPaths seek SectionCommon "indicate content of files not currently wanted"] @@ -50,7 +53,7 @@ startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ d startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart startRemote afile numcopies key remote = do showStart' ("drop " ++ Remote.name remote) key afile - next $ performRemote key numcopies remote + next $ performRemote key afile numcopies remote performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform performLocal key afile numcopies knownpresentremote = lockContent key $ do @@ -60,7 +63,8 @@ performLocal key afile numcopies knownpresentremote = lockContent key $ do Just r -> nub (Remote.uuid r:trusteduuids) untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids) - ifM (canDropKey key numcopies trusteduuids' tocheck []) + u <- getUUID + ifM (canDrop u key afile numcopies trusteduuids' tocheck []) ( do removeAnnex key notifyDrop afile True @@ -70,8 +74,8 @@ performLocal key afile numcopies knownpresentremote = lockContent key $ do stop ) -performRemote :: Key -> NumCopies -> Remote -> CommandPerform -performRemote key numcopies remote = lockContent key $ do +performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform +performRemote key afile numcopies remote = lockContent key $ do -- Filter the remote it's being dropped from out of the lists of -- places assumed to have the key, and places to check. -- When the local repo has the key, that's one additional copy. @@ -83,7 +87,7 @@ performRemote key numcopies remote = lockContent key $ do untrusteduuids <- trustGet UnTrusted let tocheck = filter (/= remote) $ Remote.remotesWithoutUUID remotes (have++untrusteduuids) - stopUnless (canDropKey key numcopies have tocheck [uuid]) $ do + stopUnless (canDrop uuid key afile numcopies have tocheck [uuid]) $ do ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok where @@ -102,13 +106,19 @@ cleanupRemote key remote ok = do {- Checks specified remotes to verify that enough copies of a key exist to - allow it to be safely removed (with no data loss). Can be provided with - - some locations where the key is known/assumed to be present. -} -canDropKey :: Key -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool -canDropKey key numcopies have check skip = do - force <- Annex.getState Annex.force - if force || numcopies == NumCopies 0 - then return True - else findCopies key numcopies skip have check + - some locations where the key is known/assumed to be present. + - + - Also checks if it's required content, and refuses to drop if so. + - + - --force overrides and always allows dropping. + -} +canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool +canDrop dropfrom key afile numcopies have check skip = ifM (Annex.getState Annex.force) + ( return True + , checkRequiredContent dropfrom key afile + <&&> + findCopies key numcopies skip have check + ) findCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool findCopies key need skip = helper [] [] @@ -144,6 +154,19 @@ notEnoughCopies key need have skip bad = do unsafe = showNote "unsafe" hint = showLongNote "(Use --force to override this check, or adjust numcopies.)" +checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool +checkRequiredContent u k afile = + ifM (isRequiredContent (Just u) S.empty (Just k) afile False) + ( requiredContent + , return True + ) + +requiredContent :: Annex Bool +requiredContent = do + showLongNote "That file is required content, it cannot be dropped!" + showLongNote "(Use --force to override this check, or adjust required content configuration.)" + return False + {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. -} checkDropAuto :: Maybe Remote -> FilePath -> Key -> (NumCopies -> CommandStart) -> CommandStart diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 5d1923d34..ce49795c9 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -34,7 +34,7 @@ perform numcopies key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< where dropremote r = do showAction $ "from " ++ Remote.name r - Command.Drop.performRemote key numcopies r + Command.Drop.performRemote key Nothing numcopies r droplocal = Command.Drop.performLocal key Nothing numcopies Nothing from = Annex.getField $ optionName Command.Drop.dropFromOption diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index c62769c95..d7d5229da 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -61,6 +61,7 @@ data Cfg = Cfg { cfgTrustMap :: TrustMap , cfgGroupMap :: M.Map UUID (S.Set Group) , cfgPreferredContentMap :: M.Map UUID PreferredContentExpression + , cfgRequiredContentMap :: M.Map UUID PreferredContentExpression , cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression , cfgScheduleMap :: M.Map UUID [ScheduledActivity] } @@ -70,6 +71,7 @@ getCfg = Cfg <$> trustMapRaw -- without local trust overrides <*> (groupsByUUID <$> groupMap) <*> preferredContentMapRaw + <*> requiredContentMapRaw <*> groupPreferredContentMapRaw <*> scheduleMap @@ -79,6 +81,7 @@ setCfg curcfg newcfg = do mapM_ (uncurry trustSet) $ M.toList $ cfgTrustMap diff mapM_ (uncurry groupSet) $ M.toList $ cfgGroupMap diff mapM_ (uncurry preferredContentSet) $ M.toList $ cfgPreferredContentMap diff + mapM_ (uncurry requiredContentSet) $ M.toList $ cfgRequiredContentMap diff mapM_ (uncurry groupPreferredContentSet) $ M.toList $ cfgGroupPreferredContentMap diff mapM_ (uncurry scheduleSet) $ M.toList $ cfgScheduleMap diff @@ -87,6 +90,7 @@ diffCfg curcfg newcfg = Cfg { cfgTrustMap = diff cfgTrustMap , cfgGroupMap = diff cfgGroupMap , cfgPreferredContentMap = diff cfgPreferredContentMap + , cfgRequiredContentMap = diff cfgRequiredContentMap , cfgGroupPreferredContentMap = diff cfgGroupPreferredContentMap , cfgScheduleMap = diff cfgScheduleMap } @@ -102,6 +106,7 @@ genCfg cfg descs = unlines $ intercalate [""] , preferredcontent , grouppreferredcontent , standardgroups + , requiredcontent , schedule ] where @@ -137,6 +142,11 @@ genCfg cfg descs = unlines $ intercalate [""] [ com "Repository preferred contents" ] (\(s, u) -> line "wanted" u s) (\u -> line "wanted" u "standard") + + requiredcontent = settings cfg descs cfgRequiredContentMap + [ com "Repository required contents" ] + (\(s, u) -> line "required" u s) + (\u -> line "required" u "") grouppreferredcontent = settings' cfg allgroups cfgGroupPreferredContentMap [ com "Group preferred contents" @@ -228,6 +238,12 @@ parseCfg curcfg = go [] curcfg . lines Nothing -> let m = M.insert u value (cfgPreferredContentMap cfg) in Right $ cfg { cfgPreferredContentMap = m } + | setting == "required" = + case checkPreferredContentExpression value of + Just e -> Left e + Nothing -> + let m = M.insert u value (cfgRequiredContentMap cfg) + in Right $ cfg { cfgRequiredContentMap = m } | setting == "groupwanted" = case checkPreferredContentExpression value of Just e -> Left e @@ -255,7 +271,6 @@ parseCfg curcfg = go [] curcfg . lines [ 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: " diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 480ac2e6d..ead303f1f 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -6,16 +6,19 @@ -} module Logs.PreferredContent ( - preferredContentLog, preferredContentSet, + requiredContentSet, groupPreferredContentSet, isPreferredContent, + isRequiredContent, preferredContentMap, - preferredContentMapLoad, preferredContentMapRaw, + requiredContentMap, + requiredContentMapRaw, groupPreferredContentMapRaw, checkPreferredContentExpression, setStandardGroup, + preferredRequiredMapsLoad, ) where import qualified Data.Map as M @@ -42,29 +45,43 @@ import Limit {- Checks if a file is preferred content for the specified repository - (or the current repository if none is specified). -} isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool -isPreferredContent mu notpresent mkey afile def = do +isPreferredContent = checkMap preferredContentMap + +isRequiredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool +isRequiredContent = checkMap requiredContentMap + +checkMap :: Annex (FileMatcherMap Annex) -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool +checkMap getmap mu notpresent mkey afile def = do u <- maybe getUUID return mu - m <- preferredContentMap + m <- getmap case M.lookup u m of Nothing -> return def Just matcher -> checkMatcher matcher mkey afile notpresent def -{- The map is cached for speed. -} preferredContentMap :: Annex (FileMatcherMap Annex) -preferredContentMap = maybe preferredContentMapLoad return +preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad) return =<< Annex.getState Annex.preferredcontentmap -{- Loads the map, updating the cache. -} -preferredContentMapLoad :: Annex (FileMatcherMap Annex) -preferredContentMapLoad = do +requiredContentMap :: Annex (FileMatcherMap Annex) +requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad) return + =<< Annex.getState Annex.requiredcontentmap + +preferredRequiredMapsLoad :: Annex (FileMatcherMap Annex, FileMatcherMap Annex) +preferredRequiredMapsLoad = do groupmap <- groupMap configmap <- readRemoteLog - groupwantedmap <- groupPreferredContentMapRaw - m <- simpleMap - . parseLogWithUUID ((Just .) . makeMatcher groupmap configmap groupwantedmap) - <$> Annex.Branch.get preferredContentLog - Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } - return m + let genmap l gm = simpleMap + . parseLogWithUUID ((Just .) . makeMatcher groupmap configmap gm) + <$> Annex.Branch.get l + pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw + rc <- genmap requiredContentLog M.empty + -- Required content is implicitly also preferred content, so OR + let m = M.unionWith MOr pc rc + Annex.changeState $ \s -> s + { Annex.preferredcontentmap = Just m + , Annex.requiredcontentmap = Just rc + } + return (m, rc) {- This intentionally never fails, even on unparsable expressions, - because the configuration is shared among repositories and newer diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs index ce91c2dcd..bbf5a1edc 100644 --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -21,14 +21,23 @@ import Types.Group {- Changes the preferred content configuration of a remote. -} preferredContentSet :: UUID -> PreferredContentExpression -> Annex () -preferredContentSet uuid@(UUID _) val = do +preferredContentSet = setLog preferredContentLog + +requiredContentSet :: UUID -> PreferredContentExpression -> Annex () +requiredContentSet = setLog requiredContentLog + +setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex () +setLog logfile uuid@(UUID _) val = do ts <- liftIO getPOSIXTime - Annex.Branch.change preferredContentLog $ + Annex.Branch.change logfile $ showLog id . changeLog ts uuid val . parseLog Just - Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } -preferredContentSet NoUUID _ = error "unknown UUID; cannot modify" + Annex.changeState $ \s -> s + { Annex.preferredcontentmap = Nothing + , Annex.requiredcontentmap = Nothing + } +setLog _ NoUUID _ = error "unknown UUID; cannot modify" {- Changes the preferred content configuration of a group. -} groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex () @@ -44,6 +53,10 @@ preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) preferredContentMapRaw = simpleMap . parseLog Just <$> Annex.Branch.get preferredContentLog +requiredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) +requiredContentMapRaw = simpleMap . parseLog Just + <$> Annex.Branch.get requiredContentLog + groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression) groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just <$> Annex.Branch.get groupPreferredContentLog diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index e0a51ff6a..eabc585f4 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -19,7 +19,7 @@ module Utility.Matcher ( Token(..), - Matcher, + Matcher(..), token, tokens, generate, diff --git a/debian/changelog b/debian/changelog index 53d653adc..70d90dd6d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -27,6 +27,7 @@ git-annex (5.20140321) UNRELEASED; urgency=medium in order to be usable. This can be done using git annex enableremote to add the missing settings. For details, see http://git-annex.branchable.com/bugs/problems_with_glacier/ + * Added required content configuration. -- Joey Hess <joeyh@debian.org> Fri, 21 Mar 2014 14:08:41 -0400 diff --git a/doc/required_content.mdwn b/doc/required_content.mdwn new file mode 100644 index 000000000..91c5614a8 --- /dev/null +++ b/doc/required_content.mdwn @@ -0,0 +1,17 @@ +Required content settings can be configured to do more complicated +things than just setting the required number of [[copies]] of your data. +For example, you could require that data be archived in at least two +archival repositories, and also require that one copy be stored offsite. + +The format of required content expressions is the same as +[[preferred_content]] expressions. + +Required content settings can be edited using `git annex vicfg`. +Each repository can have its own settings, and other repositories will +try to honor those settings when interacting with it. + +While [[preferred_content]] expresses a preference, it can be overridden +by simply using `git annex drop`. On the other hand, required content +settings are enforced; `git annex drop` will refuse to drop a file if +doing so would violate its required content settings. +(Although even this can be overridden using `--force`). diff --git a/doc/todo/required_content.mdwn b/doc/todo/required_content.mdwn index 851e652ae..6afeee5c9 100644 --- a/doc/todo/required_content.mdwn +++ b/doc/todo/required_content.mdwn @@ -5,3 +5,19 @@ like preferred content, which is enforced. So, required content. For example, I might want a repository that is required to contain `*.jpeg`. This would make get --auto get it (it's implicitly part of the preferred content), and would make drop refuse to drop it. + +> I've implemented the basic required content. Currently only configurable +> via `vicfg`, because I don't think a lot of people are going to want to +> use it. +> +> Note that I did not yet add the active verification discussed below. +> So if required content is set to `not inallgroup=backup`, or +> `not copies=10`, trying to drop a file will not go off and prove +> that there are 10 copies or that the file is in every repository in +> the backup group. It will assume that the location log is accurate +> and go by that. +> +> I think this is enough to cover Richard's case, at least. +> In his example, A B and C are in group anchor and have required +> content set to `include=*`, and D E F have it set to +> `not inallgroup=anchor`. --[[Joey]] |