Added required content configuration.

This includes checking when dropping files that any required content
configuration is satisfied. However, it does not yet include an active
check on the required content; the location log is trusted when checking
the required content expression.

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,
+	-- Preferred and required content settings depend on most of the
-	-- so will be reloaded whenever any configs change.
+	-- 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. -}

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 -> AssociatedFile -> NumCopies -> Remote -> CommandPerform
-performRemote key numcopies remote = lockContent key $ do
+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. -}
+ - 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
+ - Also checks if it's required content, and refuses to drop if so.
-	force <- Annex.getState Annex.force
+ -
-	if force || numcopies == NumCopies 0
+ - --force overrides and always allows dropping.
-		then return True
+ -}
-		else findCopies key numcopies skip have check
+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

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
 

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: "
 

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. -}
+requiredContentMap :: Annex (FileMatcherMap Annex)
-preferredContentMapLoad :: Annex (FileMatcherMap Annex)
+requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad) return
-preferredContentMapLoad = do
+	=<< Annex.getState Annex.requiredcontentmap
+
+preferredRequiredMapsLoad :: Annex (FileMatcherMap Annex, FileMatcherMap Annex)
+preferredRequiredMapsLoad = do
 	groupmap <- groupMap
 	configmap <- readRemoteLog
-	groupwantedmap <- groupPreferredContentMapRaw
+	let genmap l gm = simpleMap
-	m <- simpleMap
+		. parseLogWithUUID ((Just .) . makeMatcher groupmap configmap gm)
-		. parseLogWithUUID ((Just .) . makeMatcher groupmap configmap groupwantedmap)
+		<$> Annex.Branch.get l
-		<$> Annex.Branch.get preferredContentLog
+	pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw
-	Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m }
+	rc <- genmap requiredContentLog M.empty
-	return m
+	-- 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

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 }
+	Annex.changeState $ \s -> s 
-preferredContentSet NoUUID _ = error "unknown UUID; cannot modify"
+		{ 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

Utility/Matcher.hs

@@ -19,7 +19,7 @@
 
 module Utility.Matcher (
 	Token(..),
-	Matcher,
+	Matcher(..),
 	token,
 	tokens,
 	generate,

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
 

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`).

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