almost finished with applySimCommand

Added checks that repo names are ones that have been added to the sim.

Implemented preferred content etc setting. It does not need to parse the
expression in applySimCommand, instead that can be done when running the
sim. This keeps it pure.

But, it can't be entirely pure because of CommandAddTree. So made it
return an Annex action when necessary.

Moved makeMatcher into Annex.FileMatcher in preparation for using it,
but it's not used yet. Also moved checkPreferredContentExpression.

Annex/FileMatcher.hs

@@ -13,10 +13,12 @@ module Annex.FileMatcher (
 	checkFileMatcher',
 	checkMatcher,
 	checkMatcher',
+	makeMatcher,
 	matchAll,
 	PreferredContentData(..),
 	preferredContentTokens,
 	preferredContentParser,
+	checkPreferredContentExpression,
 	ParseToken,
 	parsedToMatcher,
 	mkMatchExpressionParser,
@@ -41,6 +43,8 @@ import Annex.SpecialRemote.Config (preferreddirField)
 import Git.FilePath
 import Types.Remote (RemoteConfig)
 import Types.ProposedAccepted
+import Types.StandardGroups
+import Logs.Group
 import Annex.CheckAttr
 import Annex.RepoSize.LiveUpdate
 import qualified Git.Config
@@ -302,3 +306,56 @@ call desc (Right sub) = Right $ Operation $ MatchFiles
 	, matchDesc = matchDescSimple desc
 	}
 call _ (Left err) = Left err
+
+makeMatcher
+	:: GroupMap
+	-> M.Map UUID RemoteConfig
+	-> M.Map Group PreferredContentExpression
+	-> UUID
+	-> (Matcher (MatchFiles Annex) -> Matcher (MatchFiles Annex))
+	-> (PreferredContentData -> [ParseToken (MatchFiles Annex)])
+	-> Either String (Matcher (MatchFiles Annex))
+	-> PreferredContentExpression
+	-> Either String (Matcher (MatchFiles Annex))
+makeMatcher groupmap configmap groupwantedmap u matcherf mktokens unknownmatcher = go True True
+  where
+	go expandstandard expandgroupwanted expr
+		| null (lefts tokens) = Right $ matcherf $ generate $ rights tokens
+		| otherwise = Left $ unwords $ lefts tokens
+	  where
+		tokens = preferredContentParser (mktokens pcd) expr
+		pcd = PCD
+			{ matchStandard = matchstandard
+			, matchGroupWanted = matchgroupwanted
+			, getGroupMap = pure groupmap
+			, configMap = configmap
+			, repoUUID = Just u
+			}
+		matchstandard
+			| expandstandard = maybe unknownmatcher (go False False)
+				(standardPreferredContent <$> getStandardGroup mygroups)
+			| otherwise = unknownmatcher
+		matchgroupwanted
+			| expandgroupwanted = maybe unknownmatcher (go True False)
+				(groupwanted mygroups)
+			| otherwise = unknownmatcher
+		mygroups = fromMaybe S.empty (u `M.lookup` groupsByUUID groupmap)
+		groupwanted s = case M.elems $ M.filterWithKey (\k _ -> S.member k s) groupwantedmap of
+			[pc] -> Just pc
+			_ -> Nothing
+
+{- Checks if an expression can be parsed, if not returns Just error -}
+checkPreferredContentExpression :: PreferredContentExpression -> Maybe String
+checkPreferredContentExpression expr = 
+	case parsedToMatcher (MatcherDesc mempty) tokens of
+		Left e -> Just e
+		Right _ -> Nothing
+  where
+	tokens = preferredContentParser (preferredContentTokens pcd) expr
+	pcd = PCD
+		{ matchStandard = Right matchAll
+		, matchGroupWanted = Right matchAll
+		, getGroupMap = pure emptyGroupMap
+		, configMap = M.empty
+		, repoUUID = Nothing
+		}

Annex/Sim.hs

@@ -11,13 +11,14 @@ module Annex.Sim where
 
 import Utility.DataUnits
 import Types.NumCopies
-import Types.FileMatcher
 import Types.RepoSize
 import Types.Key
 import Types.UUID
+import Types.StandardGroups
 import Annex (Annex)
 import Backend.Hash (genTestKey)
 import Annex.UUID
+import Annex.FileMatcher
 import Utility.FileSystemEncoding
 import qualified Remote
 
@@ -47,9 +48,9 @@ data SimState = SimState
 	, simRng :: StdGen
 	, simNumCopies :: NumCopies
 	, simGroups :: M.Map RepoName (S.Set GroupName)
-	, simWanted :: M.Map RepoName Matcher
+	, simWanted :: M.Map RepoName PreferredContentExpression
-	, simRequired :: M.Map RepoName Matcher
+	, simRequired :: M.Map RepoName PreferredContentExpression
-	, simGroupWanted :: M.Map GroupName Matcher
+	, simGroupWanted :: M.Map GroupName PreferredContentExpression
 	, simMaxSize :: M.Map RepoName MaxSize
 	, simRebalance :: Bool
 	, simExistingRepoByName :: ExistingRepoByName
@@ -89,11 +90,6 @@ setPresentKey repo k rst = rst
 		M.insertWith S.union k (S.singleton repo) (simLocations rst)
 	}
 
-data Matcher = Matcher String (FileMatcher Annex)
-
-instance Show Matcher where
-	show (Matcher s _) = s
-
 newtype RepoName = RepoName { fromRepoName :: String }
 	deriving (Show, Eq, Ord)
 
@@ -106,7 +102,7 @@ data SimCommand
 	| CommandUse RepoName String
 	| CommandConnect RepoName RepoName
 	| CommandDisconnect RepoName RepoName
-	| CommandAddTree RepoName Matcher
+	| CommandAddTree RepoName PreferredContentExpression
 	| CommandAdd FilePath ByteSize RepoName
 	| CommandStep Int
 	| CommandSeed Int
@@ -115,50 +111,58 @@ data SimCommand
 	| CommandNumCopies Int
 	| CommandGroup RepoName GroupName
 	| CommandUngroup RepoName GroupName
-	| CommandWanted RepoName String
+	| CommandWanted RepoName PreferredContentExpression
-	| CommandRequired RepoName String
+	| CommandRequired RepoName PreferredContentExpression
-	| CommandGroupWanted GroupName String
+	| CommandGroupWanted GroupName PreferredContentExpression
 	| CommandMaxSize RepoName MaxSize
 	| CommandRebalance Bool
 	deriving (Show)
 
-applySimCommand :: SimCommand -> SimState -> Either String SimState
+applySimCommand
+	:: SimCommand
+	-> SimState
+	-> Either String (Either (Annex SimState) SimState)
 applySimCommand (CommandInit reponame) st =
 	let (u, st') = genSimUUID st reponame
-	in Right $ st'
+	in Right $ Right $ st'
 		{ simRepos = M.insert reponame u (simRepos st')
 		}
 applySimCommand (CommandInitRemote reponame) st =
 	let (u, st') = genSimUUID st reponame
-	in Right $ st'
+	in Right $ Right $ st'
 		{ simSpecialRemotes = M.insert reponame u (simSpecialRemotes st')
 		}
 applySimCommand (CommandUse reponame s) st =
-	case existingRepoByName (simExistingRepoByName st) reponame of
+	case existingRepoByName (simExistingRepoByName st) s of
-		(u:[], _) -> Right $ st
+		(u:[], _) -> Right $ Right $ st
 			{ simSpecialRemotes = M.insert reponame u (simSpecialRemotes st)
 			}
 		(_, msg) -> Left $ "Unable to use a repository \"" 
 			++ fromRepoName reponame 
 			++ "\" in the simulation because " ++ msg
-applySimCommand (CommandConnect repo remote) st = Right $ st
+applySimCommand (CommandConnect repo remote) st = 
-	{ simConnections = 
+	checkKnownRepo repo st $ checkKnownRepo remote st $ Right $ Right $ st
-		let s = case M.lookup repo (simConnections st) of
+		{ simConnections = 
-			Just s -> S.insert remote s
+			let s = case M.lookup repo (simConnections st) of
-			Nothing -> S.singleton remote
+				Just cs -> S.insert remote cs
-		in M.insert repo s (simConnections st)
+				Nothing -> S.singleton remote
-	}
+			in M.insert repo s (simConnections st)
-applySimCommand (CommandDisconnect repo remote) st = Right $ st
+		}
-	{ simConnections = 
+applySimCommand (CommandDisconnect repo remote) st = 
-		let sc = case M.lookup repo (simConnections st) of
+	checkKnownRepo repo st $ checkKnownRepo remote st $ Right $ Right $ st
-			Just s -> S.delete remote s
+		{ simConnections = 
-			Nothing -> S.empty
+			let sc = case M.lookup repo (simConnections st) of
-		in M.insert repo sc (simConnections st)
+				Just s -> S.delete remote s
-	}
+				Nothing -> S.empty
-applySimCommand (CommandAddTree repo matcher) st = error "TODO" -- XXX
+			in M.insert repo sc (simConnections st)
-applySimCommand (CommandAdd file sz repo) st = 
+		}
+applySimCommand (CommandAddTree repo expr) st =
+	checkKnownRepo repo st $
+		checkValidPreferredContentExpression expr $ Left $
+			error "TODO" -- XXX
+applySimCommand (CommandAdd file sz repo) st = checkKnownRepo repo st $
 	let (k, st') = genSimKey sz st
-	in Right $ st'
+	in Right $ Right $ st'
 		{ simFiles = M.insert file k (simFiles st')
 		, simRepoState = 
 			let rst = fromMaybe emptySimRepoState $
@@ -170,53 +174,79 @@ applySimCommand (CommandStep n) st
 	| n > 0 = applySimCommand
 		(CommandStep (pred n))
 		(fst $ stepSimulation st)
-	| otherwise = Right st
+	| otherwise = Right $ Right st
-applySimCommand (CommandSeed rngseed) st = Right $ st
+applySimCommand (CommandSeed rngseed) st = Right $ Right $ st
 	{ simRng = mkStdGen rngseed
 	}
-applySimCommand (CommandPresent repo file) st =
+applySimCommand (CommandPresent repo file) st = checkKnownRepo repo st $
 	case (M.lookup file (simFiles st), M.lookup repo (simRepoState st)) of
 		(Just k, Just rst) -> case M.lookup k (simLocations rst) of
-			Just locs | S.member repo locs -> Right st
+			Just locs | S.member repo locs -> Right $ Right st
 			_ -> missing
-		(Just k, Nothing) -> missing
+		(Just _, Nothing) -> missing
 		(Nothing, _) -> Left $ "Expected " ++ file
 			++ " to be present in " ++ fromRepoName repo 
 			++ ", but the simulation does not include that file."
   where
 	missing = Left $ "Expected " ++ file ++ " to be present in " 
 		++ fromRepoName repo ++ ", but it is not."
-applySimCommand (CommandNotPresent repo file) st =
+applySimCommand (CommandNotPresent repo file) st = checkKnownRepo repo st $
 	case (M.lookup file (simFiles st), M.lookup repo (simRepoState st)) of
 		(Just k, Just rst) -> case M.lookup k (simLocations rst) of
-			Just locs | S.notMember repo locs -> Right st
+			Just locs | S.notMember repo locs -> Right $ Right st
 			_ -> present
-		(Just k, Nothing) -> present
+		(Just _, Nothing) -> present
 		(Nothing, _) -> Left $ "Expected " ++ file
 			++ " to not be present in " ++ fromRepoName repo 
 			++ ", but the simulation does not include that file."
   where
 	present = Left $ "Expected " ++ file ++ " not to be present in " 
 		++ fromRepoName repo ++ ", but it is present."
-applySimCommand (CommandNumCopies n) st = Right $ st
+applySimCommand (CommandNumCopies n) st = Right $ Right $ st
 	{ simNumCopies = configuredNumCopies n
 	}
-applySimCommand (CommandGroup repo group) st = Right $ st
+applySimCommand (CommandGroup repo group) st = checkKnownRepo repo st $
-	{ simGroups = M.insertWith S.union repo (S.singleton group) (simGroups st)
+	Right $ Right $ st
-	}
+		{ simGroups = M.insertWith S.union repo
-applySimCommand (CommandUngroup repo group) st = Right $ st
+			(S.singleton group)
-	{ simGroups = M.adjust (S.delete group) repo (simGroups st)
+			(simGroups st)
-	}
+		}
-applySimCommand (CommandWanted repo expr) st = undefined -- XXX
+applySimCommand (CommandUngroup repo group) st = checkKnownRepo repo st $
-applySimCommand (CommandRequired repo expr) st = undefined -- XXX
+	Right $ Right $ st
-applySimCommand (CommandGroupWanted group expr) st = undefined  -- XXX
+		{ simGroups = M.adjust (S.delete group) repo (simGroups st)
-applySimCommand (CommandMaxSize repo sz) st = Right $ st
+		}
-	{ simMaxSize = M.insert repo sz (simMaxSize st)
+applySimCommand (CommandWanted repo expr) st = checkKnownRepo repo st $
-	}
+	checkValidPreferredContentExpression expr $ Right $ st
-applySimCommand (CommandRebalance b) st = Right $ st
+		{ simWanted = M.insert repo expr (simWanted st)
+		}
+applySimCommand (CommandRequired repo expr) st = checkKnownRepo repo st $
+	checkValidPreferredContentExpression expr $ Right $ st
+		{ simRequired = M.insert repo expr (simRequired st)
+		}
+applySimCommand (CommandGroupWanted group expr) st =
+	checkValidPreferredContentExpression expr $ Right $ st
+		{ simGroupWanted = M.insert group expr (simGroupWanted st)
+		}
+applySimCommand (CommandMaxSize repo sz) st = checkKnownRepo repo st $
+	Right $ Right $ st
+		{ simMaxSize = M.insert repo sz (simMaxSize st)
+		}
+applySimCommand (CommandRebalance b) st = Right $ Right $ st
 	{ simRebalance = b
 	}
 
+checkKnownRepo :: RepoName -> SimState -> Either String a -> Either String a
+checkKnownRepo reponame st a = case M.lookup reponame (simRepos st) of
+	Just _ -> a
+	Nothing -> Left $ "No repository in the simulation is named \""
+		++ fromRepoName reponame ++ "\"."
+
+checkValidPreferredContentExpression :: PreferredContentExpression -> v -> Either String v
+checkValidPreferredContentExpression expr v =
+	case checkPreferredContentExpression expr of
+		Nothing -> Right v
+		Just e -> Left $ "Failed parsing \"" ++ expr ++ "\": " ++ e
+
 simRandom :: SimState -> (StdGen -> (v, StdGen)) -> (v -> r) -> (r, SimState)
 simRandom st mk f =
 	let (v, rng) = mk (simRng st)
@@ -247,13 +277,11 @@ simUUIDNameSpace = U5.generateNamed U5.namespaceURL $
         B.unpack "http://git-annex.branchable.com/git-annex-sim/"
 
 newtype ExistingRepoByName = ExistingRepoByName 
-	{ existingRepoByName :: RepoName -> ([UUID], String)
+	{ existingRepoByName :: String -> ([UUID], String)
 	}
 
 instance Show ExistingRepoByName where
 	show _ = "ExistingRepoByName"
 
 mkExistingRepoByName :: Annex ExistingRepoByName
-mkExistingRepoByName = do
+mkExistingRepoByName = ExistingRepoByName <$> Remote.nameToUUID''
-	f <- Remote.nameToUUID''
-	return $ ExistingRepoByName $ f . fromRepoName

Logs/PreferredContent.hs

@@ -1,6 +1,6 @@
 {- git-annex preferred content matcher configuration
  -
- - Copyright 2012-2023 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -25,11 +25,6 @@ module Logs.PreferredContent (
 	prop_standardGroups_parse,
 ) where
 
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Either
-import qualified Data.Attoparsec.ByteString.Lazy as A
-
 import Annex.Common
 import Logs.PreferredContent.Raw
 import qualified Annex.Branch
@@ -39,13 +34,15 @@ import Logs.UUIDBased
 import Utility.Matcher
 import Annex.FileMatcher
 import Annex.UUID
-import Types.Group
-import Types.Remote (RemoteConfig)
 import Logs.Group
 import Logs.Remote
 import Types.StandardGroups
 import Limit
 
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.Attoparsec.ByteString.Lazy as A
+
 {- Checks if a file is preferred content (or required content) for the
  - specified repository (or the current repository if none is specified). -}
 isPreferredContent :: LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
@@ -99,7 +96,8 @@ preferredRequiredMapsLoad' matcherf mktokens = do
 	groupmap <- groupMap
 	configmap <- remoteConfigMap
 	let genmap l gm = 
-		let mk u = makeMatcher groupmap configmap gm u matcherf mktokens
+		let mk u = makeMatcher groupmap configmap
+			gm u matcherf mktokens (Right (unknownMatcher u))
 		in simpleMap
 			. parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString)
 			<$> Annex.Branch.get l
@@ -115,46 +113,11 @@ preferredRequiredMapsLoad' matcherf mktokens = do
 	combiner (Left a)  (Right _) = Left a
 	combiner (Right _) (Left b)  = Left b
 
-{- This intentionally never fails, even on unparsable expressions,
+{- Parsing preferred content expressions intentionally never fails,
  - because the configuration is shared among repositories and newer
- - versions of git-annex may add new features. -}
+ - versions of git-annex may add new features.
-makeMatcher
+ -
-	:: GroupMap
+ - When a preferred content expression cannot be parsed, but is already
-	-> M.Map UUID RemoteConfig
-	-> M.Map Group PreferredContentExpression
-	-> UUID
-	-> (Matcher (MatchFiles Annex) -> Matcher (MatchFiles Annex))
-	-> (PreferredContentData -> [ParseToken (MatchFiles Annex)])
-	-> PreferredContentExpression
-	-> Either String (Matcher (MatchFiles Annex))
-makeMatcher groupmap configmap groupwantedmap u matcherf mktokens = go True True
-  where
-	go expandstandard expandgroupwanted expr
-		| null (lefts tokens) = Right $ matcherf $ generate $ rights tokens
-		| otherwise = Left $ unwords $ lefts tokens
-	  where
-		tokens = preferredContentParser (mktokens pcd) expr
-		pcd = PCD
-			{ matchStandard = matchstandard
-			, matchGroupWanted = matchgroupwanted
-			, getGroupMap = pure groupmap
-			, configMap = configmap
-			, repoUUID = Just u
-			}
-		matchstandard
-			| expandstandard = maybe (Right $ unknownMatcher u) (go False False)
-				(standardPreferredContent <$> getStandardGroup mygroups)
-			| otherwise = Right $ unknownMatcher u
-		matchgroupwanted
-			| expandgroupwanted = maybe (Right $ unknownMatcher u) (go True False)
-				(groupwanted mygroups)
-			| otherwise = Right $ unknownMatcher u
-		mygroups = fromMaybe S.empty (u `M.lookup` groupsByUUID groupmap)
-		groupwanted s = case M.elems $ M.filterWithKey (\k _ -> S.member k s) groupwantedmap of
-			[pc] -> Just pc
-			_ -> Nothing
-
-{- When a preferred content expression cannot be parsed, but is already
  - in the log (eg, put there by a newer version of git-annex),
  - the fallback behavior is to match only files that are currently present.
  -
@@ -165,22 +128,6 @@ unknownMatcher u = generate [present]
   where
 	present = Operation $ limitPresent (Just u)
 
-{- Checks if an expression can be parsed, if not returns Just error -}
-checkPreferredContentExpression :: PreferredContentExpression -> Maybe String
-checkPreferredContentExpression expr = 
-	case parsedToMatcher (MatcherDesc mempty) tokens of
-		Left e -> Just e
-		Right _ -> Nothing
-  where
-	tokens = preferredContentParser (preferredContentTokens pcd) expr
-	pcd = PCD
-		{ matchStandard = Right matchAll
-		, matchGroupWanted = Right matchAll
-		, getGroupMap = pure emptyGroupMap
-		, configMap = M.empty
-		, repoUUID = Nothing
-		}
-
 {- Puts a UUID in a standard group, and sets its preferred content to use
  - the standard expression for that group (unless preferred content is
  - already set). -}