diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Drop.hs | 47 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 2 | ||||
| -rw-r--r-- | Command/Vicfg.hs | 17 |
3 files changed, 52 insertions, 14 deletions
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: " |