git-annex 10.20240831 → 10.20240927

raw patch · 58 files changed

+2172/−236 lines, 58 files

Files

Annex/Difference.hs +3/−1
Annex/DirHashes.hs +4/−3
Annex/FileMatcher.hs +78/−4
Annex/Locations.hs +7/−2
Annex/Sim.hs +1404/−0
Annex/Sim/File.hs +284/−0
Assistant/Gpg.hs +7/−4
Assistant/WebApp/Pairing.hs +3/−2
Backend/Hash.hs +19/−6
Backend/VURL/Utilities.hs +2/−1
Backend/Variety.hs +1/−1
CHANGELOG +16/−0
CmdLine.hs +2/−1
CmdLine/GitAnnex.hs +2/−0
CmdLine/Usage.hs +2/−0
Command/FuzzTest.hs +1/−1
Command/Info.hs +1/−1
Command/Sim.hs +97/−0
Command/TestRemote.hs +12/−9
Command/Uninit.hs +1/−1
Database/RepoSize.hs +6/−0
Git/AutoCorrect.hs +4/−3
Git/Config.hs +12/−9
Git/Remote.hs +2/−1
Git/Sha.hs +7/−7
Git/Types.hs +2/−1
Git/UnionMerge.hs +3/−3
Limit.hs +41/−23
Limit/Wanted.hs +2/−0
Logs/MaxSize.hs +1/−0
Logs/NumCopies.hs +2/−0
Logs/PreferredContent.hs +11/−64
Logs/PreferredContent/Raw.hs +6/−2
Logs/UUID.hs +1/−0
Remote.hs +26/−10
Remote/Bup.hs +1/−1
Remote/Directory.hs +12/−7
Remote/Git.hs +14/−10
Remote/Helper/AWS.hs +1/−1
Remote/Rsync.hs +2/−1
Remote/Rsync/RsyncUrl.hs +2/−1
Test.hs +7/−6
Types/Difference.hs +15/−7
Types/FileMatcher.hs +3/−1
Types/Group.hs +1/−1
Types/Key.hs +1/−1
Types/MetaData.hs +1/−1
Types/NumCopies.hs +4/−2
Types/RepoSize.hs +3/−3
Types/TrustLevel.hs +1/−1
Upgrade/V1.hs +1/−1
Utility/Aeson.hs +1/−5
Utility/DataUnits.hs +8/−8
Utility/Matcher.hs +15/−1
Utility/Misc.hs +2/−3
Utility/PartialPrelude.hs +0/−12
Utility/Tor.hs +1/−1
git-annex.cabal +4/−1

Annex/Difference.hs view

@@ -56,5 +56,7 @@ 					else return ds 			) 		forM_ (listDifferences ds') $ \d ->-			setConfig (differenceConfigKey d) (differenceConfigVal d)+			case differenceConfigKey d of+				Nothing -> noop+				Just ck -> setConfig ck (differenceConfigVal d) 		recordDifferences ds' u

Annex/DirHashes.hs view

@@ -1,4 +1,4 @@-{- git-annex file locations+{- git-annex object file locations  -  - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -@@ -19,6 +19,7 @@  import Data.Default import Data.Bits+import qualified Data.List.NonEmpty as NE import qualified Data.ByteArray as BA import qualified Data.ByteArray.Encoding as BA import qualified Data.ByteString as S@@ -60,8 +61,8 @@  - To support that, some git-annex repositories use the lower case-hash.  - All special remotes use the lower-case hash for new data, but old data  - may still use the mixed case hash. -}-dirHashes :: [HashLevels -> Hasher]-dirHashes = [hashDirLower, hashDirMixed]+dirHashes :: NE.NonEmpty (HashLevels -> Hasher)+dirHashes = hashDirLower NE.:| [hashDirMixed]  hashDirs :: HashLevels -> Int -> S.ByteString -> RawFilePath hashDirs (HashLevels 1) sz s = P.addTrailingPathSeparator $ S.take sz s

Annex/FileMatcher.hs view

@@ -13,10 +13,12 @@ 	checkFileMatcher', 	checkMatcher, 	checkMatcher',+	makeMatcher, 	matchAll, 	PreferredContentData(..), 	preferredContentTokens, 	preferredContentParser,+	checkPreferredContentExpression, 	ParseToken, 	parsedToMatcher, 	mkMatchExpressionParser,@@ -41,6 +43,8 @@ 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@@ -95,10 +99,26 @@ 	go = do 		(matches, desc) <- runWriterT $ matchMrun' matcher $ \op -> 			matchAction op lu notpresent mi-		explain (mkActionItem mi) $ UnquotedString <$>-			describeMatchResult matchDesc desc-				((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ")-		return matches+		let descmsg = UnquotedString <$>+				describeMatchResult+					(\o -> matchDesc o . Just) desc+					((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ")+		let unstablenegated = filter matchNegationUnstable (findNegated matcher)+		if null unstablenegated+			then do+				explain (mkActionItem mi) descmsg+				return matches+			else do+				let s = concat +					[ ", but that expression is not stable due to negated use of "+					, unwords $ nub $ +						map (fromMatchDesc . flip matchDesc Nothing)+							unstablenegated+					, ", so will not be used"+					]+				explain (mkActionItem mi) $ Just $+					fromMaybe mempty descmsg <> UnquotedString s+				return False  fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo fileMatchInfo file mkey = do@@ -282,6 +302,60 @@ 	, matchNeedsKey = any matchNeedsKey sub 	, matchNeedsLocationLog = any matchNeedsLocationLog sub 	, matchNeedsLiveRepoSize = any matchNeedsLiveRepoSize sub+	, matchNegationUnstable = any matchNegationUnstable sub 	, 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/Locations.hs view

@@ -108,6 +108,7 @@ 	gitAnnexSshDir, 	gitAnnexRemotesDir, 	gitAnnexAssistantDefaultDir,+	gitAnnexSimDir, 	HashLevels(..), 	hashDirMixed, 	hashDirLower,@@ -117,6 +118,7 @@  import Data.Char import Data.Default+import qualified Data.List.NonEmpty as NE import qualified Data.ByteString.Char8 as S8 import qualified System.FilePath.ByteString as P @@ -675,6 +677,9 @@ gitAnnexAssistantDefaultDir :: FilePath gitAnnexAssistantDefaultDir = "annex" +gitAnnexSimDir :: Git.Repo -> RawFilePath+gitAnnexSimDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "sim"+ {- Sanitizes a String that will be used as part of a Key's keyName,  - dealing with characters that cause problems.  -@@ -771,5 +776,5 @@  - This is compatible with the annexLocationsNonBare and annexLocationsBare,  - for interoperability between special remotes and git-annex repos.  -}-keyPaths :: Key -> [RawFilePath]-keyPaths key = map (\h -> keyPath key (h def)) dirHashes+keyPaths :: Key -> NE.NonEmpty RawFilePath+keyPaths key = NE.map (\h -> keyPath key (h def)) dirHashes

+ Annex/Sim.hs view

@@ -0,0 +1,1404 @@+{- git-annex simulator+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Annex.Sim where++import Annex.Common+import Utility.DataUnits+import Types.NumCopies+import Types.Group+import Types.StandardGroups+import Types.TrustLevel+import Types.Difference+import Git+import Git.FilePath+import Backend.Hash (genTestKey)+import Annex.UUID+import Annex.FileMatcher+import Annex.Init+import Annex.Startup+import Annex.Link+import Annex.Wanted+import Annex.CatFile+import Annex.Action (quiesce)+import Annex.MetaData+import Logs.Group+import Logs.Trust+import Logs.PreferredContent+import Logs.NumCopies+import Logs.Remote+import Logs.MaxSize+import Logs.Difference+import Logs.UUID+import Logs.Location+import Logs.MetaData+import Utility.Env+import qualified Annex+import qualified Remote+import qualified Git.Construct+import qualified Git.LsFiles+import qualified Annex.Queue+import qualified Database.RepoSize++import System.Random+import Data.Word+import Text.Read+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.UUID as U+import qualified Data.UUID.V5 as U5+import qualified Utility.RawFilePath as R+import qualified System.FilePath.ByteString as P++data SimState t = SimState+	{ simRepos :: M.Map RepoName UUID+	, simRepoState :: M.Map UUID (SimRepoState t)+	, simConnections :: M.Map UUID (S.Set RemoteName)+	, simClusterNodes :: M.Map RepoName UUID+	, simFiles :: M.Map RawFilePath Key+	, simRng :: Int+	, simTrustLevels :: M.Map UUID TrustLevel+	, simNumCopies :: NumCopies+	, simMinCopies :: MinCopies+	, simGroups :: M.Map UUID (S.Set Group)+	, simMetaData :: M.Map Key MetaData+	, simWanted :: M.Map UUID PreferredContentExpression+	, simRequired :: M.Map UUID PreferredContentExpression+	, simGroupWanted :: M.Map Group PreferredContentExpression+	, simMaxSize :: M.Map UUID MaxSize+	, simRebalance :: Bool+	, simHistory :: [SimCommand]+	, simVectorClock :: VectorClock+	, simRootDirectory :: FilePath+	, simFailed :: Bool+	}+	deriving (Show, Read)++emptySimState :: Int -> FilePath -> SimState t+emptySimState rngseed rootdir = SimState+	{ simRepos = mempty+	, simRepoState = mempty+	, simConnections = mempty+	, simClusterNodes = mempty+	, simFiles = mempty+	, simRng = rngseed+	, simTrustLevels = mempty+	, simNumCopies = configuredNumCopies 1+	, simMinCopies = configuredMinCopies 1+	, simGroups = mempty+	, simMetaData = mempty+	, simWanted = mempty+	, simRequired = mempty+	, simGroupWanted = mempty+	, simMaxSize = mempty+	, simRebalance = False+	, simHistory = []+	, simVectorClock = VectorClock 0+	, simRootDirectory = rootdir+	, simFailed = False+	}++-- State that can vary between different repos in the simulation.+data SimRepoState t = SimRepoState+	{ simLocations :: M.Map Key (M.Map UUID LocationState)+	, simLiveSizeChanges :: M.Map UUID SizeOffset+	, simIsSpecialRemote :: Bool+	, simRepo :: Maybe t+	, simRepoName :: RepoName+	}+	deriving (Show, Read)++data LocationState = LocationState VectorClock Bool+	deriving (Eq, Show, Read)++newtype VectorClock = VectorClock Int+	deriving (Eq, Ord, Show, Read)++newerLocationState ::  LocationState -> LocationState -> LocationState+newerLocationState l1@(LocationState vc1 _) l2@(LocationState vc2 _)+	| vc1 > vc2 = l1+	| otherwise = l2+		+{- Updates the state of stu to indicate that a key is present or not in u.+ -+ - Also, when the reponame is the name of a cluster node, updates+ - the state of every other repository that has a connection to that+ - same cluster node.+ -}+setPresentKey :: Bool -> (UUID, RepoName) -> Key -> UUID -> SimState SimRepo -> SimState SimRepo+setPresentKey present (u, reponame) k stu st = handleclusters $ st+	{ simRepoState = case M.lookup stu (simRepoState st) of+		Just rst -> M.insert stu+			(setPresentKey' present (simVectorClock st) u k rst)+			(simRepoState st)+		Nothing -> error "no simRepoState in setPresentKey"+	}+  where+	handleclusters st' = case M.lookup reponame (simClusterNodes st') of+		Just u' | u' == u -> handleclusters' st' $ +			filter (/= stu) $ M.keys $ +				M.filter (S.member (repoNameToRemoteName reponame))+					(simConnections st')+		_ -> st'+	handleclusters' st' [] = st'+	handleclusters' st' (cu:cus) =+		flip handleclusters' cus $ st'+			{ simRepoState = case M.lookup cu (simRepoState st') of+				Just rst -> M.insert cu+					(setPresentKey' present (simVectorClock st') u k rst)+					(simRepoState st')+				Nothing -> simRepoState st'+			}++setPresentKey' :: Bool -> VectorClock -> UUID -> Key -> SimRepoState t -> SimRepoState t+setPresentKey' present vc u k rst = rememberLiveSizeChanges present u k rst $ rst+	{ simLocations = +		M.insertWith (M.unionWith newerLocationState) k+			(M.singleton u (LocationState vc present))+			(simLocations rst)+	}++getSimLocations :: SimRepoState t -> Key -> S.Set UUID+getSimLocations rst k =+	maybe mempty getSimLocations' $+		M.lookup k (simLocations rst)++getSimLocations' :: M.Map UUID LocationState -> S.Set UUID+getSimLocations' = M.keysSet . M.filter present+  where+	present (LocationState _ b) = b++addHistory :: SimState t -> SimCommand -> SimState t+addHistory st c = st { simHistory = c : simHistory st }++recordSeed :: SimState t -> [SimCommand] -> SimState t+recordSeed st (CommandSeed _:_) = st+recordSeed st _ = addHistory st (CommandSeed (simRng st))++newtype RepoName = RepoName { fromRepoName :: String }+	deriving (Show, Read, Eq, Ord)++newtype RemoteName = RemoteName { fromRemoteName :: String }+	deriving (Show, Read, Eq, Ord)++remoteNameToRepoName :: RemoteName -> RepoName+remoteNameToRepoName (RemoteName n) = RepoName n++repoNameToRemoteName :: RepoName -> RemoteName+repoNameToRemoteName (RepoName n) = RemoteName n++data Connections+	= RepoName :-> RemoteName+	| RemoteName :<- RepoName+	| RepoName :<-> RepoName+	| RepoName :=> Connections+	| RemoteName :<= Connections+	| RepoName :<=> Connections+	deriving (Show, Read)++leftSideOfConnection :: Connections -> RepoName+leftSideOfConnection (reponame :-> _) = reponame+leftSideOfConnection (remotename :<- _) = remoteNameToRepoName remotename+leftSideOfConnection (reponame :<-> _) = reponame+leftSideOfConnection (reponame :=> _) = reponame+leftSideOfConnection (remotename :<= _) = remoteNameToRepoName remotename+leftSideOfConnection (reponame :<=> _) = reponame++getConnection :: Connections -> (RepoName, RemoteName, Maybe Connections)+getConnection (reponame :-> remotename) = (reponame, remotename, Nothing)+getConnection (remotename :<- reponame) = (reponame, remotename, Nothing)+getConnection (reponame1 :<-> reponame2) =+	( reponame1+	, repoNameToRemoteName reponame2+	, Just (reponame2 :-> repoNameToRemoteName reponame1)+	)+getConnection (reponame :=> c) =+	(reponame, repoNameToRemoteName (leftSideOfConnection c), Just c)+getConnection (remotename :<= c) = (leftSideOfConnection c, remotename, Just c)+getConnection (reponame :<=> c) = +	( reponame+	, repoNameToRemoteName (leftSideOfConnection c)+	, Just (reponame :=> c)+	)++data SimCommand+	= CommandInit RepoName+	| CommandInitRemote RepoName+	| CommandUse RepoName String+	| CommandConnect Connections+	| CommandDisconnect Connections+	| CommandAddTree RepoName PreferredContentExpression+	| CommandAdd RawFilePath ByteSize [RepoName]+	| CommandAddMulti Int String ByteSize ByteSize [RepoName]+	| CommandStep Int+	| CommandStepStable Int+	| CommandAction SimAction+	| CommandSeed Int+	| CommandPresent RepoName RawFilePath+	| CommandNotPresent RepoName RawFilePath+	| CommandNumCopies Int+	| CommandMinCopies Int+	| CommandTrustLevel RepoName TrustLevel+	| CommandGroup RepoName Group+	| CommandUngroup RepoName Group+	| CommandMetaData RawFilePath String+	| CommandWanted RepoName PreferredContentExpression+	| CommandRequired RepoName PreferredContentExpression+	| CommandGroupWanted Group PreferredContentExpression+	| CommandRandomWanted RepoName [PreferredContentExpression]+	| CommandRandomRequired RepoName [PreferredContentExpression]+	| CommandRandomGroupWanted Group [PreferredContentExpression]+	| CommandMaxSize RepoName MaxSize+	| CommandRebalance Bool+	| CommandClusterNode RepoName RepoName+	| CommandVisit RepoName [String]+	| CommandComment String+	| CommandBlank+	deriving (Show, Read)++data SimAction+	= ActionPull RepoName RemoteName+	| ActionPush RepoName RemoteName+	| ActionSync RepoName RemoteName+	| ActionGetWanted RepoName RemoteName+	| ActionDropUnwanted RepoName (Maybe RemoteName)+	| ActionSendWanted RepoName RemoteName+	| ActionGitPush RepoName RemoteName+	| ActionGitPull RepoName RemoteName+	| ActionWhile SimAction SimAction+	deriving (Show, Read)++runSimCommand :: SimCommand -> GetExistingRepoByName -> SimState SimRepo -> Annex (SimState SimRepo)+runSimCommand cmd repobyname st = +	case applySimCommand cmd st repobyname of+		Left err -> giveup err+		Right (Right st') -> return st'+		Right (Left mkst) -> mkst++applySimCommand+	:: SimCommand+	-> SimState SimRepo+	-> GetExistingRepoByName +	-> Either String (Either (Annex (SimState SimRepo)) (SimState SimRepo))+applySimCommand (CommandPresent repo file) st _ = checkKnownRepo repo st $ \u ->+	case (M.lookup file (simFiles st), M.lookup u (simRepoState st)) of+		(Just k, Just rst)+			| u `S.member` getSimLocations rst k ->+				Right $ Right st+			| otherwise -> missing+		(Just _, Nothing) -> missing+		(Nothing, _) -> Right $ Left $ do+			showLongNote $ UnquotedString $+				"Expected " ++ fromRawFilePath file+					++ " to be present in " ++ fromRepoName repo +					++ ", but the simulation does not include that file."+			return $ st { simFailed = True }+  where+	missing = Right $ Left $ do+		showLongNote $ UnquotedString $+			"Expected " ++ fromRawFilePath file+				++ " to be present in " +				++ fromRepoName repo ++ ", but it is not."+		return $ st { simFailed = True }+applySimCommand (CommandNotPresent repo file) st _ = checkKnownRepo repo st $ \u ->+	case (M.lookup file (simFiles st), M.lookup u (simRepoState st)) of+		(Just k, Just rst)+			| u `S.notMember` getSimLocations rst k ->+				Right $ Right st+			| otherwise -> present+		(Just _, Nothing) -> present+		(Nothing, _) -> Right $ Left $ do+			showLongNote $ UnquotedString $ +				"Expected " ++ fromRawFilePath file+					++ " to not be present in " ++ fromRepoName repo +					++ ", but the simulation does not include that file."+			return $ st { simFailed = True }+  where+	present = Right $ Left $ do+		showLongNote $ UnquotedString $+			"Expected " ++ fromRawFilePath file +			++ " not to be present in " +			++ fromRepoName repo ++ ", but it is present."+		return $ st { simFailed = True }+applySimCommand c@(CommandVisit repo cmdparams) st _ =+	checkKnownRepo repo st $ \u -> Right $ Left $ do+		st' <- liftIO $ updateSimRepos st+		let dir = simRepoDirectory st' u+		unlessM (liftIO $ doesDirectoryExist dir) $+			giveup "Simulated repository unavailable."+		(cmd, params) <- case cmdparams of+			[] -> do+				showLongNote "Starting a shell in the simulated repository."+				shellcmd <- liftIO $ fromMaybe "sh" <$> getEnv "SHELL"+				return (shellcmd, [])+			_ -> return ("sh", ["-c", unwords cmdparams])+		exitcode <- liftIO $+			safeSystem' cmd (map Param params)+				(\p -> p { cwd = Just dir })+		when (null cmdparams) $+			showLongNote "Finished visit to simulated repository."+		if null cmdparams+			then return st'+			else if exitcode == ExitSuccess+				then return $ addHistory st' c+				else do+					showLongNote $ UnquotedString $ +						"Command " ++ unwords cmdparams +++							" exited nonzero."+					liftIO $ exitWith exitcode+applySimCommand cmd st repobyname = +	let st' = flip addHistory cmd $ st+		{ simVectorClock = +			let (VectorClock clk) = simVectorClock st +			in VectorClock (succ clk)+		}+	in applySimCommand' cmd st' repobyname++applySimCommand'+	:: SimCommand+	-> SimState SimRepo+	-> GetExistingRepoByName+	-> Either String (Either (Annex (SimState SimRepo)) (SimState SimRepo))+applySimCommand' (CommandInit reponame) st _ =+	checkNonexistantRepo reponame st $+		let (u, st') = genSimUUID st reponame+		in Right $ Right $ addRepo reponame (newSimRepoConfig u False) st'+applySimCommand' (CommandInitRemote reponame) st _ = +	checkNonexistantRepo reponame st $+		let (u, st') = genSimUUID st reponame+		in Right $ Right $ addRepo reponame (newSimRepoConfig u True) st'+applySimCommand' (CommandUse reponame s) st repobyname =+	case getExistingRepoByName repobyname s of+		Right existingrepo -> checkNonexistantRepo reponame st $+			Right $ Right $ addRepo reponame existingrepo st+		Left msg -> Left $ "Unable to use a repository \"" +			++ fromRepoName reponame +			++ "\" in the simulation because " ++ msg+applySimCommand' (CommandConnect connections) st repobyname =+	let (repo, remote, mconnections) = getConnection connections+	in checkKnownRepo repo st $ \u -> +		if maybe False simIsSpecialRemote (M.lookup u (simRepoState st))+			then Left $ fromRepoName repo ++ " is a special remote, and cannot connect to " ++ fromRemoteName remote+			else go u remote mconnections+  where+	go u remote mconnections =+		let st' = st+			{ simConnections = +				let s = case M.lookup u (simConnections st) of+					Just cs -> S.insert remote cs+					Nothing -> S.singleton remote+				in M.insert u s (simConnections st)+			}+		in case mconnections of+			Nothing -> Right $ Right st'+			Just connections' ->+				applySimCommand' (CommandConnect connections') st' repobyname+applySimCommand' (CommandDisconnect connections) st repobyname = +	let (repo, remote, mconnections) = getConnection connections+	in checkKnownRepo repo st $ \u -> +		let st' = st+			{ simConnections = +				let sc = case M.lookup u (simConnections st) of+					Just s -> S.delete remote s+					Nothing -> S.empty+				in M.insert u sc (simConnections st)+			}+		in case mconnections of+			Nothing -> Right $ Right $ st+			Just connections' ->+				applySimCommand' (CommandDisconnect connections') st' repobyname+applySimCommand' (CommandAddTree repo expr) st _ =+	checkKnownRepo repo st $ \u ->+		checkValidPreferredContentExpression [expr] $ Left $ do+			matcher <- makematcher u+			(l, cleanup) <- inRepo $ Git.LsFiles.inRepo [] []+			st' <- go matcher u st l+			liftIO $ void cleanup+			return st'+  where+	go _ _ st' [] = return st'+	go matcher u st' (f:fs) = catKeyFile f  >>= \case+		Just k -> do+			afile <- AssociatedFile . Just . getTopFilePath+				<$> inRepo (toTopFilePath f)+			ifM (checkMatcher matcher (Just k) afile NoLiveUpdate mempty (pure False) (pure False))+				( let st'' = setPresentKey True (u, repo) k u $ st'+					{ simFiles = M.insert f k (simFiles st')+					}+				  in go matcher u st'' fs+				, go matcher u st' fs +				)+		Nothing -> go matcher u st' fs+	makematcher :: UUID -> Annex (FileMatcher Annex)+	makematcher u = do+		groupmap <- groupMap+		configmap <- remoteConfigMap+		gm <- groupPreferredContentMapRaw+		case makeMatcher groupmap configmap gm u id preferredContentTokens parseerr expr of+			Right matcher -> return+				( matcher+				, MatcherDesc "provided preferred content expression"+				)+			Left err -> giveup err+	parseerr = Left "preferred content expression parse error"+applySimCommand' (CommandAdd file sz repos) st _ = +	let (k, st') = genSimKey sz st+	in go k st' repos+  where+	go _k st' [] = Right $ Right st'+	go k st' (repo:rest) = checkKnownRepo repo st' $ \u ->+		let st'' = setPresentKey True (u, repo) k u $ st'+			{ simFiles = M.insert file k (simFiles st')+			}+		in go k st'' rest+applySimCommand' (CommandAddMulti n suffix minsz maxsz repos) st repobyname = +	let (sz, st') = simRandom st (randomR (minsz, maxsz)) id+	    file = toRawFilePath (show n ++ suffix)+	in case applySimCommand' (CommandAdd file sz repos) st' repobyname of+		Left err -> Left err+		Right (Right st'') ->+			case pred n of+				0 -> Right (Right st'')+				n' -> applySimCommand' (CommandAddMulti n' suffix minsz maxsz repos) st'' repobyname+		Right (Left _) -> error "applySimCommand' CommandAddMulti"+applySimCommand' (CommandStep n) st _ = +	Right $ Left $ handleStep False n n st+applySimCommand' (CommandStepStable n) st _ = +	Right $ Left $ handleStep True n n st+applySimCommand' (CommandAction act) st _ =+	case getSimActionComponents act st of+		Left err -> Left err+		Right (Right st') -> Right (Right st')+		Right (Left (st', l)) -> Right $ Left $ go l st'+  where+	go [] st' = return st'+	go (a:as) st' = do+		(st'', _) <- a st'+		go as st''+applySimCommand' (CommandSeed rngseed) st _ =+	Right $ Right $ st+		{ simRng = rngseed+		}+applySimCommand' (CommandNumCopies n) st _ =+	Right $ Right $ st+		{ simNumCopies = configuredNumCopies n+		}+applySimCommand' (CommandMinCopies n) st _ =+	Right $ Right $ st+		{ simMinCopies = configuredMinCopies n+		}+applySimCommand' (CommandTrustLevel repo trustlevel) st _ =+	checkKnownRepo repo st $ \u ->+		 Right $ Right $ st+			{ simTrustLevels = M.insert u trustlevel+				(simTrustLevels st)+			}+applySimCommand' (CommandGroup repo groupname) st _ = +	checkKnownRepo repo st $ \u ->+		Right $ Right $ st+			{ simGroups = M.insertWith S.union u+				(S.singleton groupname)+				(simGroups st)+			}+applySimCommand' (CommandUngroup repo groupname) st _ = +	checkKnownRepo repo st $ \u ->+		Right $ Right $ st+			{ simGroups = M.adjust (S.delete groupname) u (simGroups st)+			}+applySimCommand' (CommandMetaData file modmetaexpr) st _ =+	case parseModMeta modmetaexpr of+		Left err -> Left err+		Right modmeta -> case M.lookup file (simFiles st) of+			Nothing -> Left $ "Cannot set metadata of unknown file " ++ fromRawFilePath file+			Just k -> Right $ Right $ st+				{ simMetaData = M.alter (addmeta modmeta) k+					(simMetaData st)+				}+  where+	addmeta modmeta (Just metadata) = Just $ unionMetaData metadata $+		modMeta metadata modmeta+	addmeta modmeta Nothing = Just $ modMeta emptyMetaData modmeta+applySimCommand' (CommandWanted repo expr) st _ = +	checkKnownRepo repo st $ \u ->+		checkValidPreferredContentExpression [expr] $ Right $ st+			{ simWanted = M.insert u expr (simWanted st)+			}+applySimCommand' (CommandRequired repo expr) st _ = +	checkKnownRepo repo st $ \u ->+		checkValidPreferredContentExpression [expr] $ Right $ st+			{ simRequired = M.insert u expr (simRequired st)+			}+applySimCommand' (CommandGroupWanted groupname expr) st _ =+	checkValidPreferredContentExpression [expr] $ Right $ st+		{ simGroupWanted = M.insert groupname expr (simGroupWanted st)+		}+applySimCommand' (CommandRandomWanted repo terms) st _ = +	checkKnownRepo repo st $ \u ->+		checkValidPreferredContentExpression terms $ Right $+			randomPreferredContentExpression st terms $ \(expr, st') -> st' +				{ simWanted = M.insert u expr (simWanted st')+				}+applySimCommand' (CommandRandomRequired repo terms) st _ = +	checkKnownRepo repo st $ \u ->+		checkValidPreferredContentExpression terms $ Right $+			randomPreferredContentExpression st terms $ \(expr, st') -> st' +				{ simRequired = M.insert u expr (simRequired st)+				}+applySimCommand' (CommandRandomGroupWanted groupname terms) st _ =+	checkValidPreferredContentExpression terms $ Right $+		randomPreferredContentExpression st terms $ \(expr, st') -> st' +			{ simGroupWanted = M.insert groupname expr (simGroupWanted st)+			}+applySimCommand' (CommandMaxSize repo sz) st _ = +	checkKnownRepo repo st $ \u ->+		Right $ Right $ st+			{ simMaxSize = M.insert u sz (simMaxSize st)+			}+applySimCommand' (CommandClusterNode nodename repo) st _ =+	checkKnownRepo repo st $ \u ->+		checkNonexistantRepo nodename st $+			Right $ Right $ st+				{ simClusterNodes = M.insert nodename u+					(simClusterNodes st)+				}+applySimCommand' (CommandRebalance b) st _ = +	Right $ Right $ st+		{ simRebalance = b+		}+applySimCommand' (CommandComment _) st _ = Right $ Right st+applySimCommand' CommandBlank st _ = Right $ Right st+applySimCommand' (CommandVisit _ _) _ _ = error "applySimCommand' CommandVisit"+applySimCommand' (CommandPresent _ _) _ _ = error "applySimCommand' CommandPresent"+applySimCommand' (CommandNotPresent _ _) _ _ = error "applySimCommand' CommandNotPresent"++handleStep :: Bool -> Int -> Int -> SimState SimRepo -> Annex (SimState SimRepo)+handleStep muststabilize startn n st+	| n >= 0 = do+		let (st', actions) = getactions unsyncactions st+		(st'', restactions) <- runoneaction actions st'+		if null restactions+			then do+				let (st''', actions') = getactions [ActionSync] st''+				(st'''', restactions') <- runoneaction actions' st'''+				if null restactions'+					then do+						showLongNote $ UnquotedString $ +							"Simulation has stabilized after "+							++ show (startn - n)+							++ " steps."+						return st''''+					else runrest restactions' st'''' (pred n)+			else runrest restactions st'' (pred n)+	| otherwise = checkstabalized st+  where+	runrest actions st' n'+		| n' >= 0 = do+			(st'', restactions) <- runoneaction actions st'+			if null restactions+				then handleStep muststabilize startn n' st'+				else runrest restactions st'' (pred n')+		| otherwise = checkstabalized st'++	checkstabalized st'+		| muststabilize = do+			showLongNote $ UnquotedString $ +				"Simulation failed to stabilize after "+					++ show startn ++ " steps."+			return $ st' { simFailed = True }+		| otherwise = return st'++	unsyncactions = +		[ ActionGetWanted+		, ActionSendWanted+		, \repo remote -> ActionDropUnwanted repo (Just remote)+		]++	getactions mks st' = getcomponents [] st' $+		getactions' mks [] (M.toList (simRepos st'))++	getactions' _ c [] = concat c+	getactions' mks c ((repo, u):repos) = +		case M.lookup u (simConnections st) of+			Nothing -> getactions' mks c repos+			Just remotes ->+				let l = [mk repo remote | remote <- S.toList remotes, mk <- mks]+				in getactions' mks (l:c) repos+	+	getcomponents c st' [] = (st', concat c)+	getcomponents c st' (a:as) = case getSimActionComponents a st' of+		Left _ -> getcomponents c st' as+		Right (Right st'') -> getcomponents c st'' as+		Right (Left (st'', cs)) -> getcomponents (cs:c) st'' as+	+	runoneaction [] st' = return (st', [])+	runoneaction actions st' = do+		let (idx, st'') = simRandom st'+                  	(randomR (0, length actions - 1))+			id+		let action = actions !! idx+		let restactions = take idx actions ++ drop (idx+1) actions+		action st'' >>= \case+			(st''', False) -> runoneaction restactions st'''+			(st''', True) -> return (st''', restactions)++getSimActionComponents+	:: SimAction+	-> SimState SimRepo+	-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo, Bool)]) (SimState SimRepo))+getSimActionComponents (ActionGetWanted repo remote) st =+	checkKnownRepoNotSpecialRemote repo st $ \u -> +		let go _remoteu f k _r st' = setPresentKey True (u, repo) k u $+			addHistory st' $ CommandPresent repo f+		in overFilesRemote repo u remote S.member S.notMember wanted go st+  where+	wanted k f _ = wantGet NoLiveUpdate False k f+getSimActionComponents (ActionSendWanted repo remote) st = +	checkKnownRepoNotSpecialRemote repo st $ \u ->+		overFilesRemote repo u remote S.notMember S.member wanted (go u) st+  where+	wanted = wantGetBy NoLiveUpdate False+	go u remoteu f k _r st' = +		-- Sending to a remote updates the location log+		-- of both the repository sending and the remote.+		setpresent remoteu $+		setpresent u $+		addHistory st' $ CommandPresent (remoteNameToRepoName remote) f+	  where+	  	setpresent = setPresentKey True (remoteu, remoteNameToRepoName remote) k+getSimActionComponents (ActionDropUnwanted repo Nothing) st =+	checkKnownRepoNotSpecialRemote repo st $ \u ->+		simulateDropUnwanted st u repo u+getSimActionComponents (ActionDropUnwanted repo (Just remote)) st =+	checkKnownRepo repo st $ \u ->+		checkKnownRemote remote repo u st $ \ru ->+			simulateDropUnwanted st u (remoteNameToRepoName remote) ru+getSimActionComponents (ActionGitPush repo remote) st =+	checkKnownRepoNotSpecialRemote repo st $ \u -> +		checkKnownRemote remote repo u st $ \_ ->+			simulateGitAnnexMerge repo (remoteNameToRepoName remote) st+getSimActionComponents (ActionGitPull repo remote) st =+	checkKnownRepoNotSpecialRemote repo st $ \u -> +		checkKnownRemote remote repo u st $ \_ ->+			simulateGitAnnexMerge (remoteNameToRepoName remote) repo st+getSimActionComponents (ActionWhile a b) st =+	case getSimActionComponents a st of+		Left err -> Left err+		Right (Right st') -> getSimActionComponents b st'+		Right (Left (st', as)) ->+			case getSimActionComponents b st' of+				Left err -> Left err+				Right (Right st'') -> Right $ Left (st'', as)+				Right (Left (st'', bs)) ->+					Right $ Left $ mingle as bs st'' []+  where+	mingle [] subbs st' c = (st', reverse c ++ subbs)+	mingle subas [] st' c = (st', reverse c ++ subas)+	mingle (suba:subas) (subb:subbs) st' c = +		let (coinflip, st'') = simRandom st' random id+		in if coinflip+			then mingle subas (subb:subbs) st'' (suba:c)+			else mingle (suba:subas) subbs st'' (subb:c)+getSimActionComponents (ActionPull repo remote) st =+	simActionSequence+		[ ActionGitPull repo remote+		, ActionGetWanted repo remote+		, ActionDropUnwanted repo Nothing+		] st+getSimActionComponents (ActionPush repo remote) st =+	simActionSequence+		[ ActionSendWanted repo remote+		, ActionDropUnwanted repo (Just remote)+		, ActionGitPush repo remote+		] st+getSimActionComponents (ActionSync repo remote) st =+	simActionSequence+		[ ActionGitPull repo remote+		, ActionGetWanted repo remote+		, ActionSendWanted repo remote+		, ActionDropUnwanted repo (Just remote)+		, ActionGitPush repo remote+		] st++simActionSequence+	:: [SimAction]+	-> SimState SimRepo+	-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo, Bool)]) (SimState SimRepo))+simActionSequence [] st = Right (Right st)+simActionSequence (a:as) st = case getSimActionComponents a st of+	Left err -> Left err+	Right (Right st') -> simActionSequence as st'+	Right (Left (st', subas)) -> go st' subas as+  where+	go st' c [] = Right $ Left (st', c)+	go st' c (a':as') = case getSimActionComponents a' st' of+		Left err -> Left err+		Right (Right st'') -> go st'' c as'+		Right (Left (st'', subas)) -> go st'' (c ++ subas) as'++overFilesRemote+	:: RepoName+	-> UUID+	-> RemoteName+	-> (UUID -> S.Set UUID -> Bool) +	-> (UUID -> S.Set UUID -> Bool) +	-> (Maybe Key -> AssociatedFile -> UUID -> Annex Bool)+        -> (UUID -> RawFilePath -> Key -> RepoName -> SimState SimRepo -> SimState SimRepo)+	-> SimState SimRepo+	-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo, Bool)]) (SimState SimRepo))+overFilesRemote r u remote remotepred localpred checkwant handlewanted st = +	checkKnownRemote remote r u st $ \remoteu ->+		Right (Left (st, map (go remoteu) $ M.toList $ simFiles st))+  where+	go remoteu (f, k) st' = +	  	let af = AssociatedFile $ Just f+		in liftIO $ runSimRepo u st' $ \st'' rst ->+			case M.lookup remoteu (simRepoState st'') of+				Nothing -> return (st'', False)+				Just rmtst+					| not (checkremotepred remoteu rst k) -> return (st'', False)+					| not (checkremotepred remoteu rmtst k) -> return (st'', False)+					| not (checklocalpred rst k) -> return (st'', False)+					| otherwise -> updateLiveSizeChanges rst $+						ifM (checkwant (Just k) af remoteu)+							( return (handlewanted remoteu f k r st'', True)+							, return (st'', False)+							)+	checkremotepred remoteu rst k =+		remotepred remoteu (getSimLocations rst k)+	checklocalpred rst k =+		localpred u (getSimLocations rst k)++simulateGitAnnexMerge+	:: RepoName+	-> RepoName+	-> SimState SimRepo+	-> Either String (Either a (SimState SimRepo))+simulateGitAnnexMerge src dest st = +	case (M.lookup src (simRepos st), M.lookup dest (simRepos st)) of+		(Just srcu, Just destu) -> case M.lookup destu (simRepoState st) of+			Nothing -> Left $ "Unable to find simRepoState for " ++ fromRepoName dest+			Just destst -> case M.lookup srcu (simRepoState st) of+				Nothing -> Left $ "Unable to find simRepoState for " ++ fromRepoName src+				Just srcst -> Right $ Right $+					simulateGitAnnexMerge' srcst destst destu st+		_ -> Left $ "Unable to find " ++ fromRepoName src ++ " or " ++ fromRepoName dest ++ " in simRepos"++simulateGitAnnexMerge' :: SimRepoState SimRepo -> SimRepoState SimRepo -> UUID -> SimState SimRepo -> SimState SimRepo+simulateGitAnnexMerge' srcst destst destu st = +	let locs = M.unionWith+		(M.unionWith newerLocationState)+		(simLocations destst)+		(simLocations srcst)+	    destst' = calcLiveSizeChanges $ destst+	    	{ simLocations = locs+		}+	in st+		{ simRepoState = M.insert destu destst' (simRepoState st)+		}++simulateDropUnwanted+	:: SimState SimRepo+	-> UUID+	-> RepoName+	-> UUID+	-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo, Bool)]) (SimState SimRepo))+simulateDropUnwanted st u dropfromname dropfrom =+	Right $ Left (st, map go $ M.toList $ simFiles st)+  where+	go (f, k) st' = liftIO $ runSimRepo u st' $ \st'' rst ->+		let af = AssociatedFile $ Just f+		in if present dropfrom rst k+			then updateLiveSizeChanges rst $+				ifM (wantDrop NoLiveUpdate False (Just dropfrom) (Just k) af Nothing)+					( return $ checkdrop rst k f st''+					, return (st'', False)+					)+			else return (st'', False)++	present ru rst k = ru `S.member` getSimLocations rst k++	checkdrop rst k f st' =+		let numcopies = simNumCopies st'+		    mincopies = simMinCopies st'+		    verifiedcopies = mapMaybe (verifypresent k st') $+		    	filter (/= dropfrom) $ S.toList $ getSimLocations rst k+		in case safeDropAnalysis numcopies mincopies verifiedcopies Nothing of+			UnsafeDrop -> (st', False)+			SafeDrop -> (dodrop k f st', True)+			SafeDropCheckTime -> (dodrop k f st', True)++	dodrop k f st' =+		setPresentKey False (dropfrom, dropfromname) k u $+			setPresentKey False (dropfrom, dropfromname) k dropfrom $+				addHistory st' $ CommandNotPresent dropfromname f+	+	remotes = S.fromList $ mapMaybe +		(\remote -> M.lookup (remoteNameToRepoName remote) (simRepos st))+		(maybe mempty S.toList $ M.lookup u $ simConnections st)+	+	verifypresent k st' ru = do+		rst <- M.lookup ru (simRepoState st')+		if present ru rst k+			then if ru `S.member` remotes || ru == u+				then Just $ if simIsSpecialRemote rst+					then mkVerifiedCopy RecentlyVerifiedCopy ru+					else mkVerifiedCopy LockedCopy ru+				else case M.lookup ru (simTrustLevels st') of+					Just Trusted -> Just $+						mkVerifiedCopy TrustedCopy ru+					_ -> Nothing+			else Nothing++checkNonexistantRepo :: RepoName -> SimState SimRepo -> Either String a -> Either String a+checkNonexistantRepo reponame st a = case M.lookup reponame (simRepos st) of+	Nothing -> case M.lookup reponame (simClusterNodes st) of+		Just _ -> Left $ "There is already a cluster node in the simulation named \""+			++ fromRepoName reponame ++ "\"."+		Nothing -> a+	Just _ -> Left $ "There is already a repository in the simulation named \""+		++ fromRepoName reponame ++ "\"."++checkKnownRepo :: RepoName -> SimState SimRepo -> (UUID -> Either String a) -> Either String a+checkKnownRepo reponame st a = case M.lookup reponame (simRepos st) of+	Just u -> a u+	Nothing -> case M.lookup reponame (simClusterNodes st) of+		Just u -> a u+		Nothing -> Left $ "No repository in the simulation is named \""+			++ fromRepoName reponame ++ "\". Choose from: "+			++ unwords (map fromRepoName $ M.keys (simRepos st))++checkKnownRepoNotSpecialRemote :: RepoName -> SimState SimRepo -> (UUID -> Either String a) -> Either String a+checkKnownRepoNotSpecialRemote reponame st a =+	checkKnownRepo reponame st $ \u -> +		 if maybe False simIsSpecialRemote (M.lookup u (simRepoState st))+		 	then Left $ fromRepoName reponame ++ " is a special remote, so git-annex cannot run on it."+			else a u++checkKnownRemote :: RemoteName -> RepoName -> UUID -> SimState SimRepo -> (UUID -> Either String a) -> Either String a+checkKnownRemote remotename reponame u st a =+	let rs = fromMaybe mempty $ M.lookup u (simConnections st)+	in if S.member remotename rs+		then checkKnownRepo (remoteNameToRepoName remotename) st a+		else Left $ "Repository " ++ fromRepoName reponame +			++ " does not have a remote \"" +			++ fromRemoteName remotename ++ "\"."++checkValidPreferredContentExpression :: [PreferredContentExpression] -> v -> Either String v+checkValidPreferredContentExpression [] v = Right v+checkValidPreferredContentExpression (expr:rest) v =+	case checkPreferredContentExpression expr of+		Nothing -> checkValidPreferredContentExpression rest v+		Just e -> Left $ "Failed parsing \"" ++ expr ++ "\": " ++ e++simRandom :: SimState t -> (StdGen -> (v, StdGen)) -> (v -> r) -> (r, SimState t)+simRandom st mk f =+	let rng = mkStdGen (simRng st)+	    (v, rng') = mk rng+	    (newseed, _) = random rng'+	in (f v, st { simRng = newseed })++randomPreferredContentExpression :: SimState SimRepo -> [String] -> ((PreferredContentExpression, SimState SimRepo) -> t) -> t+randomPreferredContentExpression st terms f = +	f (simRandom st (randomPreferredContentExpression' terms) id)++randomPreferredContentExpression' :: [String] -> StdGen -> (PreferredContentExpression, StdGen)+randomPreferredContentExpression' terms rng = +	let (n, rng') = randomR (1, nterms) rng+	in go [] n rng'+  where+	go c 0 rng' = (unwords (concat c), rng')+	go c n rng' = +		let (idx, rng'') = randomR (0, nterms - 1) rng'+		    term = terms !! idx+		    (notted, rng''') = random rng''+		    (combineand, rng'''') = random rng'''+		    combiner = if null c+		    	then []+			else if combineand then ["and"] else ["or"]+		    subexpr = if notted +		    	then "not":term:combiner+		    	else term:combiner+		in go (subexpr:c) (pred n) rng''''+	nterms = length terms++randomWords :: Int -> StdGen -> ([Word8], StdGen)+randomWords = go []+  where+	go c n g+		| n < 1 = (c, g)+		| otherwise = +			let (w, g') = random g+			in go (w:c) (pred n) g'++genSimKey :: ByteSize -> SimState t -> (Key, SimState t)+genSimKey sz st = simRandom st (randomWords 1024) mk+  where+	mk b =+		let tk = genTestKey $ L.pack b+		in alterKey tk $ \kd -> kd { keySize = Just sz }++genSimUUID :: SimState t -> RepoName -> (UUID, SimState t)+genSimUUID st (RepoName reponame) = simRandom st (randomWords 1024)+	(\l -> genUUIDInNameSpace simUUIDNameSpace (encodeBS reponame <> B.pack l))++simUUIDNameSpace :: U.UUID+simUUIDNameSpace = U5.generateNamed U5.namespaceURL $+        B.unpack "http://git-annex.branchable.com/git-annex-sim/"++newtype GetExistingRepoByName = GetExistingRepoByName +	{ getExistingRepoByName :: String -> Either String SimRepoConfig+	}++instance Show GetExistingRepoByName where+	show _ = "GetExistingRepoByName"++data SimRepoConfig = SimRepoConfig+	{ simRepoConfigUUID :: UUID+	, simRepoConfigIsSpecialRemote :: Bool+	, simRepoConfigGroups :: S.Set Group+	, simRepoConfigTrustLevel :: TrustLevel+	, simRepoConfigPreferredContent :: Maybe PreferredContentExpression+	, simRepoConfigRequiredContent :: Maybe PreferredContentExpression+	, simRepoConfigGroupPreferredContent :: M.Map Group PreferredContentExpression+	, simRepoConfigMaxSize :: Maybe MaxSize+	}+	deriving (Show)++newSimRepoConfig :: UUID -> Bool -> SimRepoConfig+newSimRepoConfig u isspecialremote = SimRepoConfig+	{ simRepoConfigUUID = u +	, simRepoConfigIsSpecialRemote = isspecialremote+	, simRepoConfigGroups = mempty+	, simRepoConfigTrustLevel = def+	, simRepoConfigPreferredContent = Nothing+	, simRepoConfigRequiredContent = Nothing+	, simRepoConfigGroupPreferredContent = mempty+	, simRepoConfigMaxSize = Nothing+	}++addRepo :: RepoName -> SimRepoConfig -> SimState SimRepo -> SimState SimRepo+addRepo reponame simrepo st = st+	{ simRepos = M.insert reponame u (simRepos st)+	, simRepoState = M.insert u rst (simRepoState st)+	, simConnections = M.insert u mempty (simConnections st)+	, simGroups = M.insert u (simRepoConfigGroups simrepo) (simGroups st)+	, simTrustLevels = M.insert u+		(simRepoConfigTrustLevel simrepo)+		(simTrustLevels st)+	, simWanted = M.alter+		(const $ simRepoConfigPreferredContent simrepo)+		u+		(simWanted st)+	, simRequired = M.alter+		(const $ simRepoConfigRequiredContent simrepo)+		u+		(simRequired st)+	, simGroupWanted = M.union +		(simRepoConfigGroupPreferredContent simrepo)+		(simGroupWanted st)+	, simMaxSize = M.alter+		(const $ simRepoConfigMaxSize simrepo)+		u+		(simMaxSize st)+	}+  where+	u = simRepoConfigUUID simrepo+	rst = SimRepoState+		{ simLocations = mempty+		, simLiveSizeChanges = mempty+		, simIsSpecialRemote = simRepoConfigIsSpecialRemote simrepo+		, simRepo = Nothing+		, simRepoName = reponame+		}++mkGetExistingRepoByName :: Annex GetExistingRepoByName+mkGetExistingRepoByName = do+	groupmap <- groupMap+	trustmap <- trustMap+	pcmap <- preferredContentMapRaw+	rcmap <- requiredContentMapRaw+	gpcmap <- groupPreferredContentMapRaw+	maxsizes <- getMaxSizes+	nametouuid <- Remote.nameToUUID''+	remoteconfigmap <- readRemoteLog+	return $ GetExistingRepoByName $ \name -> +		case nametouuid name of+			(u:[], _) -> Right $ +				let gs = fromMaybe S.empty $+					M.lookup u (groupsByUUID groupmap)+				in SimRepoConfig+					{ simRepoConfigUUID = u+					, simRepoConfigIsSpecialRemote =+						M.member u remoteconfigmap+					, simRepoConfigGroups = gs+					, simRepoConfigTrustLevel =+						lookupTrust' u trustmap+					, simRepoConfigPreferredContent =+						M.lookup u pcmap+					, simRepoConfigRequiredContent =+						M.lookup u rcmap+					, simRepoConfigGroupPreferredContent =+						M.restrictKeys gpcmap gs+					, simRepoConfigMaxSize =+						M.lookup u maxsizes+					}+			(_, msg) -> Left msg++-- Information about a git repository that is cloned and used to represent+-- a repository in the simulation+data SimRepo = SimRepo+	{ simRepoGitRepo :: Repo+	, simRepoAnnex :: (Annex.AnnexState, Annex.AnnexRead)+	, simRepoCurrState :: SimState SimRepo+	, simRepoUUID :: UUID+	}++instance Show SimRepo where+	show _ = "SimRepo"++{- Inits and updates SimRepos to reflect the SimState. -}+updateSimRepos :: SimState SimRepo -> IO (SimState SimRepo)+updateSimRepos st = updateSimRepoStates st >>= initNewSimRepos++updateSimRepoStates :: SimState SimRepo -> IO (SimState SimRepo)+updateSimRepoStates = overSimRepoStates updateSimRepoState++quiesceSim :: SimState SimRepo -> IO (SimState SimRepo)+quiesceSim = overSimRepoStates go+  where+	go st sr = do+		((), astrd) <- Annex.run (simRepoAnnex sr) $ doQuietAction $+			quiesce False+		return $ sr+			{ simRepoAnnex = astrd+			, simRepoCurrState = st+			}++overSimRepoStates :: (SimState SimRepo -> SimRepo -> IO SimRepo) -> SimState SimRepo -> IO (SimState SimRepo)+overSimRepoStates a inst = go inst (M.toList $ simRepoState inst)+  where+	go st [] = return st+	go st ((u, rst):rest) = case simRepo rst of+		Just sr -> do+			sr' <- a st sr+			let rst' = rst { simRepo = Just sr' }+			let st' = st+				{ simRepoState = M.insert u rst'+					(simRepoState st)+				}+			go st' rest+		Nothing -> go st rest++initNewSimRepos :: SimState SimRepo -> IO (SimState SimRepo)+initNewSimRepos = \st -> go st (M.toList $ simRepoState st)+  where+	go st [] = return st+	go st ((u, rst):rest) =+		case simRepo rst of+			Nothing -> do+				let d = simRepoDirectory st u+				sr <- initSimRepo (simRepoName rst) u d st+				let rst' = rst { simRepo = Just sr }+				let st' = st+					{ simRepoState = M.insert u rst'+						(simRepoState st)+					}+				go st' rest+			_ -> go st rest++simRepoDirectory :: SimState t -> UUID -> FilePath+simRepoDirectory st u = simRootDirectory st </> fromUUID u++initSimRepo :: RepoName -> UUID -> FilePath -> SimState SimRepo -> IO SimRepo+initSimRepo simreponame u dest st = do+	inited <- boolSystem "git" +		[ Param "init"+		, Param "--quiet"+		, File dest+		]+	unless inited $+		giveup "git init failed"+	simrepo <- Git.Construct.fromPath (toRawFilePath dest)+	ast <- Annex.new simrepo+	((), ast') <- Annex.run ast $ doQuietAction $ do+		storeUUID u+		-- Prevent merging this simulated git-annex branch with+		-- any real one.+		recordDifferences simulationDifferences u+		let desc = simulatedRepositoryDescription simreponame+		initialize startupAnnex (Just desc) Nothing+	updateSimRepoState st $ SimRepo+		{ simRepoGitRepo = simrepo+		, simRepoAnnex = ast'+		, simRepoCurrState = +			emptySimState (simRng st) (simRootDirectory st)+		, simRepoUUID = u+		}++simulatedRepositoryDescription :: RepoName -> String+simulatedRepositoryDescription simreponame = +	"simulated repository " ++ fromRepoName simreponame++simulationDifferences :: Differences+simulationDifferences = mkDifferences $ S.singleton Simulation++runSimRepo :: UUID -> SimState SimRepo -> (SimState SimRepo -> SimRepoState SimRepo -> Annex (SimState SimRepo, t)) -> IO (SimState SimRepo, t)+runSimRepo u st a = do+	st' <- updateSimRepos st+	case M.lookup u (simRepoState st') of+		Just rst -> case simRepo rst of+			Just sr -> do+				((st'', t), strd) <- Annex.run (simRepoAnnex sr) $+					doQuietAction (a st' rst)+				let sr' = sr+					{ simRepoAnnex = strd+					}+				let st''' = st''+					{ simRepoState = M.adjust+						(\rst' -> rst' { simRepo = Just sr' })+						u+						(simRepoState st'')+					}+				return (st''', t)+			Nothing -> error $ "runSimRepo simRepo not set for " ++ fromUUID u+		Nothing -> error $ "runSimRepo simRepoState not found for " ++ fromUUID u++rememberLiveSizeChanges :: Bool -> UUID -> Key -> SimRepoState t -> SimRepoState t -> SimRepoState t+rememberLiveSizeChanges present u k oldrst newrst+	| u `S.member` getSimLocations oldrst k == present = newrst+	| otherwise = +		let m = M.alter go u (simLiveSizeChanges newrst)+		in newrst { simLiveSizeChanges = m }+  where+	ksz = fromMaybe 0 $ fromKey keySize k+	change+		| present = SizeOffset ksz+		| otherwise = SizeOffset (negate ksz)++	go Nothing = Just change+	go (Just oldoffset) = Just (oldoffset + change)++calcLiveSizeChanges :: SimRepoState t -> SimRepoState t+calcLiveSizeChanges rst = rst+	{ simLiveSizeChanges = go mempty $ M.toList $ simLocations rst+	}+  where+	go m [] = m+	go m ((k, locm):rest) = go (go' k m (M.toList locm)) rest++	go' _ m [] = m+	go' k m ((u, locst):rest) = go' k (M.alter (calc k locst) u m) rest++	calc k (LocationState _ present) msz+		| not present = msz+		| otherwise = Just $ fromMaybe (SizeOffset 0) msz + +			SizeOffset (fromMaybe 0 $ fromKey keySize k)++{- Update the RepoSize database in a simulated repository as if LiveUpdate+ - were done for the simulated changes in keys locations that have occurred+ - in the simulation up to this point.+ - + - This relies on the SizeChanges table being a rolling total. When the+ - simulation is suspended, the location logs get updated with changes+ - corresponding to the size changes recorded here. When the simulation is+ - later resumed, the values written here are taken as the start values+ - for the rolling total, and so getLiveRepoSizes will only see the+ - difference between that start value and whatever new value is written+ - here.+ -+ - This assumes that the simulation is not interrupted after calling+ - this, but before it can update the location logs.+ -}+updateLiveSizeChanges :: SimRepoState t -> Annex a -> Annex a+updateLiveSizeChanges rst a = do+	h <- Database.RepoSize.getRepoSizeHandle+	liftIO $ Database.RepoSize.setSizeChanges h $+		M.map fromSizeOffset $ simLiveSizeChanges rst+	a++updateSimRepoState :: SimState SimRepo -> SimRepo -> IO SimRepo+updateSimRepoState newst sr = do+	((), (ast, ard)) <- Annex.run (simRepoAnnex sr) $ doQuietAction $ do+		let oldst = simRepoCurrState sr+		updateField oldst newst simRepos $ DiffUpdate+			{ replaceDiff = const . setdesc+			, addDiff = setdesc+			, removeDiff = const $ const noop+			}+		updateField oldst newst simTrustLevels $ DiffUpdate+			{ replaceDiff = const . trustSet+			, addDiff = trustSet+			, removeDiff = const . flip trustSet def+			}+		when (simNumCopies oldst /= simNumCopies newst) $+			setGlobalNumCopies (simNumCopies newst)+		when (simMinCopies oldst /= simMinCopies newst) $+			setGlobalMinCopies (simMinCopies newst)+		updateField oldst newst simGroups $ DiffUpdate+			{ replaceDiff = \u -> const . groupChange u . const+			, addDiff = \u -> groupChange u . const+			, removeDiff = const . flip groupChange (const mempty)+			}+		updateField oldst newst simMetaData $ DiffUpdate+			{ replaceDiff = replaceNew addMetaData+			, addDiff = addMetaData+			, removeDiff = \k old -> addMetaData k $+				modMeta old DelAllMeta+			}+		updateField oldst newst simWanted $ DiffUpdate+			{ replaceDiff = replaceNew preferredContentSet+			, addDiff = preferredContentSet+			, removeDiff = const . flip preferredContentSet mempty+			}+		updateField oldst newst simRequired $ DiffUpdate+			{ replaceDiff = replaceNew requiredContentSet+			, addDiff = requiredContentSet+			, removeDiff = const . flip requiredContentSet mempty+			}+		updateField oldst newst simGroupWanted $ DiffUpdate+			{ replaceDiff = replaceNew groupPreferredContentSet+			, addDiff = groupPreferredContentSet+			, removeDiff = const . flip groupPreferredContentSet mempty+			}+		updateField oldst newst simMaxSize $ DiffUpdate+			{ replaceDiff = replaceNew recordMaxSize+			, addDiff = recordMaxSize+			, removeDiff = const . flip recordMaxSize (MaxSize 0)+			}+		updateField oldst newst getlocations $ DiffUpdate+			{ replaceDiff = \k newls oldls -> do+				let news = getSimLocations' newls+				let olds = getSimLocations' oldls+				setlocations InfoPresent k+					(S.difference news olds)+				setlocations InfoMissing k+					(S.difference olds news)+			, addDiff = \k ls -> setlocations InfoPresent k+				(getSimLocations' ls)+			, removeDiff = \k ls -> setlocations InfoMissing k+				(getSimLocations' ls)+			}+		updateField oldst newst simFiles $ DiffUpdate+			{ replaceDiff = replaceNew stageannexedfile+			, addDiff = stageannexedfile+			, removeDiff = const . unstageannexedfile+			}+		Annex.Queue.flush+	let ard' = ard { Annex.rebalance = simRebalance newst }+	return $ sr+		{ simRepoAnnex = (ast, ard')+		, simRepoCurrState = newst+		}+  where+	setdesc r u = describeUUID u $ toUUIDDesc $+		simulatedRepositoryDescription r+	stageannexedfile f k = do+		let f' = annexedfilepath f+		l <- calcRepo $ gitAnnexLink f' k+		liftIO $ createDirectoryIfMissing True $+			takeDirectory $ fromRawFilePath f'+		addAnnexLink l f'+	unstageannexedfile f = do+		liftIO $ removeWhenExistsWith R.removeLink $+			annexedfilepath f+	annexedfilepath f = repoPath (simRepoGitRepo sr) P.</> f+	getlocations = maybe mempty simLocations+		. M.lookup (simRepoUUID sr)+		. simRepoState+	setlocations s k =+		mapM_ (\l -> logChange NoLiveUpdate k l s)++data DiffUpdate a b m = DiffUpdate+	{ replaceDiff :: a -> b -> b -> m ()+	-- ^ The first value is the new one, the second is the old one.+	, addDiff :: a -> b -> m ()+	, removeDiff :: a -> b -> m ()+	}++replaceNew :: (a -> b -> m ()) -> a -> b -> b -> m ()+replaceNew f a new _old = f a new++updateMap+	:: (Monad m, Ord a, Eq b)+	=> M.Map a b+	-> M.Map a b+	-> DiffUpdate a b m+	-> m ()+updateMap old new diffupdate = do+	forM_ (M.toList $ M.intersectionWith (,) new old) $ +		\(k, (newv, oldv))->+			when (newv /= oldv) $+				replaceDiff diffupdate k newv oldv+	forM_ (M.toList $ M.difference new old) $+		uncurry (addDiff diffupdate)+	forM_ (M.toList $ M.difference old new) $+		\(k, oldv) -> removeDiff diffupdate k oldv++updateField+	:: (Monad m, Ord a, Eq b)+	=> v+	-> v+	-> (v -> M.Map a b)+	-> DiffUpdate a b m+	-> m ()+updateField old new f = updateMap (f old) (f new)++suspendSim :: SimState SimRepo -> IO ()+suspendSim st = do+	-- Update the sim repos before suspending, so that at restore time+	-- they are up-to-date.+	st' <- quiesceSim =<< updateSimRepos st+	let st'' = st'+		{ simRepoState = M.map freeze (simRepoState st')+		}+	writeFile (simRootDirectory st'' </> "state") (show st'')+  where+	freeze :: SimRepoState SimRepo -> SimRepoState ()+	freeze rst = rst { simRepo = Nothing }++restoreSim :: RawFilePath -> IO (Either String (SimState SimRepo))+restoreSim rootdir = +	tryIO (readFile (fromRawFilePath rootdir </> "state")) >>= \case+		Left err -> return (Left (show err))+		Right c -> case readMaybe c :: Maybe (SimState ()) of+			Nothing -> return (Left "unable to parse sim state file")+			Just st -> do+				let st' = st { simRootDirectory = fromRawFilePath rootdir }+				repostate <- M.fromList+					<$> mapM (thaw st') (M.toList (simRepoState st))+				let st'' = st'+					{ simRepoState = +						M.map (finishthaw st'') repostate+					}+				return (Right st'')+  where+	thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case+		Left _ -> (u, rst { simRepo = Nothing })+		Right r -> (u, rst { simRepo = Just r })+	thaw' st u = do+		simrepo <- Git.Construct.fromPath $ toRawFilePath $+			simRepoDirectory st u+		ast <- Annex.new simrepo+		return $ SimRepo+			{ simRepoGitRepo = simrepo+			, simRepoAnnex = ast+			, simRepoCurrState =+				-- Placeholder, replaced later with current+				-- state.+				emptySimState (simRng st)+					(simRootDirectory st)+			, simRepoUUID = u+			}+	finishthaw st rst = rst+		{ simRepo = case simRepo rst of+			Nothing -> Nothing+			Just sr -> Just $ sr { simRepoCurrState = st }+		}

+ Annex/Sim/File.hs view

@@ -0,0 +1,284 @@+{- sim files+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Sim.File where++import Annex.Sim+import Annex.Common hiding (group)+import Utility.DataUnits+import Types.TrustLevel+import Types.Group+import Git.Config (isTrueFalse)++import Data.Char+import Text.Read++parseSimFile :: String -> Either String [SimCommand]+parseSimFile = go [] . lines+  where+	go cs [] = Right (reverse cs)+	go cs (l:ls) = case parseSimFileLine l of+		Right command -> go (command:cs) ls+		Left err -> Left err++parseSimFileLine :: String -> Either String SimCommand+parseSimFileLine s+	| "#" `isPrefixOf` s || "--" `isPrefixOf` s = +		Right (CommandComment s)+	| all isSpace s = Right (CommandBlank)+	| otherwise = parseSimCommand (words s)++generateSimFile :: [SimCommand] -> String+generateSimFile = unlines . map unwords . go+  where+	go [] = []+	go (CommandInit (RepoName name) : rest) = +		["init", name] : go rest+	go (CommandInitRemote (RepoName name) : rest) =+		["initremote", name] : go rest+	go (CommandUse (RepoName name) what : rest) =+		["use", name, what] : go rest+	go (CommandConnect c : rest) =+		("connect":formatConnections c) : go rest+	go (CommandDisconnect c : rest) =+		("disconnect":formatConnections c) : go rest+	go (CommandAddTree (RepoName name) expr : rest) =+		["addtree", name, expr] : go rest+	go (CommandAdd f sz repos : rest) =+		(["add", fromRawFilePath f, showsize sz] ++ map fromRepoName repos) : go rest+	go (CommandAddMulti n suffix minsz maxsz repos : rest) =+		(["addmulti", show n, suffix, showsize minsz, showsize maxsz] ++ map fromRepoName repos) : go rest+	go (CommandStep n : rest) =+		["step", show n] : go rest+	go (CommandStepStable n : rest) =+		["stepstable", show n] : go rest+	go (CommandAction act : rest) = formatAction act : go rest+	go (CommandSeed n : rest) =+		["seed", show n] : go rest+	go (CommandPresent (RepoName repo) f : rest) =+		["present", repo, fromRawFilePath f] : go rest+	go (CommandNotPresent (RepoName repo) f : rest) =+		["notpresent", repo, fromRawFilePath f] : go rest+	go (CommandNumCopies n : rest) = +		["numcopies", show n] : go rest+	go (CommandMinCopies n : rest) =+		["mincopies", show n] : go rest+	go (CommandTrustLevel (RepoName repo) trustlevel : rest) =+		["trustlevel", repo, showTrustLevel trustlevel] : go rest+	go (CommandGroup (RepoName repo) group : rest) =+		["group", repo, fromGroup group] : go rest+	go (CommandUngroup (RepoName repo) group : rest) =+		["ungroup", repo, fromGroup group] : go rest+	go (CommandMetaData f modmeta : rest) =+		["metadata", fromRawFilePath f, modmeta] : go rest+	go (CommandWanted (RepoName repo) expr : rest) =+		["wanted", repo, expr] : go rest+	go (CommandRequired (RepoName repo) expr : rest) =+		["required", repo, expr] : go rest+	go (CommandGroupWanted group expr : rest) =+		["groupwanted", fromGroup group, expr] : go rest+	go (CommandRandomWanted (RepoName repo) terms : rest) =+		("randomwanted" : repo : terms) : go rest+	go (CommandRandomRequired (RepoName repo) terms : rest) =+		("randomrequired" : repo : terms) : go rest+	go (CommandRandomGroupWanted group terms : rest) =+		("randomgroupwanted" : fromGroup group : terms) : go rest+	go (CommandMaxSize (RepoName repo) maxsize : rest) =+		["maxsize", repo, showsize (fromMaxSize maxsize)] : go rest+	go (CommandRebalance b : rest) =+		["rebalance", if b then "on" else "off"] : go rest+	go (CommandClusterNode (RepoName nodename) (RepoName repo) : rest) =+		["clusternode", nodename, repo] : go rest+	go (CommandVisit (RepoName repo) cmdparams : rest) =+		(["visit", repo] ++ cmdparams) : go rest+	go (CommandComment s : rest) = +		[s] : go rest+	go (CommandBlank : rest) = +		[""] : go rest++	showsize = filter (not . isSpace) . preciseSize storageUnits True++formatAction :: SimAction -> [String]+formatAction (ActionPull (RepoName repo) (RemoteName remote)) =+	["action", repo, "pull", remote]+formatAction (ActionPush (RepoName repo) (RemoteName remote)) =+	["action", repo, "push", remote]+formatAction (ActionSync (RepoName repo) (RemoteName remote)) =+	["action", repo, "sync", remote]+formatAction (ActionGetWanted (RepoName repo) (RemoteName remote)) =+	["action", repo, "getwanted", remote]+formatAction (ActionDropUnwanted (RepoName repo) (Just (RemoteName remote))) =+	["action", repo, "dropunwantedfrom", remote]+formatAction (ActionDropUnwanted (RepoName repo) Nothing) =+	["action", repo, "dropunwanted"]+formatAction (ActionSendWanted (RepoName repo) (RemoteName remote)) =+	["action", repo, "sendwanted", remote]+formatAction (ActionGitPush (RepoName repo) (RemoteName remote)) =+	["action", repo, "gitpush", remote]+formatAction (ActionGitPull (RepoName repo) (RemoteName remote)) =+	["action", repo, "gitpull", remote]+formatAction (ActionWhile a b) =+	formatAction a ++ ["while"] ++ formatAction b++parseSimCommand :: [String] -> Either String SimCommand+parseSimCommand ("init":name:[]) = +	Right $ CommandInit (RepoName name)+parseSimCommand ("initremote":name:[]) =+	Right $ CommandInitRemote (RepoName name)+parseSimCommand ("use":name:rest) =+	Right $ CommandUse (RepoName name) (unwords rest)+parseSimCommand	("connect":rest) = +	CommandConnect <$> parseConnections rest+parseSimCommand	("disconnect":rest) =+	CommandDisconnect <$> parseConnections rest+parseSimCommand ("addtree":name:rest) =+	Right $ CommandAddTree(RepoName name) (unwords rest)+parseSimCommand ("add":filename:size:repos) =+	case readSize dataUnits size of+		Just sz -> Right $ CommandAdd+			(toRawFilePath filename)+			sz+			(map RepoName repos)+		Nothing -> Left $ "Unable to parse file size \"" ++ size ++ "\""+parseSimCommand ("addmulti":num:suffix:minsize:maxsize:repos) =+	case readSize dataUnits minsize of+		Just minsz -> case readSize dataUnits maxsize of+			Just maxsz -> case readMaybe num of+				Just n -> Right $ CommandAddMulti +					n suffix minsz maxsz+					(map RepoName repos)+				Nothing -> Left $ "Unable to parse number \"" ++ num ++ "\""+			Nothing -> Left $ "Unable to parse file size \"" ++ maxsize ++ "\""+		Nothing -> Left $ "Unable to parse file size \"" ++ minsize ++ "\""+parseSimCommand ("step":n:[]) =+	case readMaybe n of+			Just n' -> Right $ CommandStep n'+			Nothing -> Left $ "Unable to parse step value \"" ++ n ++ "\""+parseSimCommand ("stepstable":n:[]) =+	case readMaybe n of+			Just n' -> Right $ CommandStepStable n'+			Nothing -> Left $ "Unable to parse step value \"" ++ n ++ "\""+parseSimCommand l@("action":_) = case parseSimAction l of+	Right act -> Right $ CommandAction act+	Left err -> Left err+parseSimCommand	("seed":n:[]) =+	case readMaybe n of+		Just n' -> Right $ CommandSeed n'+		Nothing -> Left $ "Unable to parse seed value \"" ++ n ++ "\""+parseSimCommand ("present":repo:file:[]) =+	Right $ CommandPresent (RepoName repo) (toRawFilePath file)+parseSimCommand ("notpresent":repo:file:[]) =+	Right $ CommandNotPresent (RepoName repo) (toRawFilePath file)+parseSimCommand ("numcopies":n:[]) =+	case readMaybe n of+		Just n' -> Right $ CommandNumCopies n'+		Nothing -> Left $ "Unable to parse numcopies value \"" ++ n ++ "\""+parseSimCommand ("mincopies":n:[]) =+	case readMaybe n of+		Just n' -> Right $ CommandMinCopies n'+		Nothing -> Left $ "Unable to parse mincopies value \"" ++ n ++ "\""+parseSimCommand ("trustlevel":repo:s:[]) =+	case readTrustLevel s of+		Just trustlevel -> Right $ +			CommandTrustLevel (RepoName repo) trustlevel+		Nothing -> Left $ "Unknown trust level \"" ++ s ++ "\"."+parseSimCommand ("group":repo:group:[]) =+	Right $ CommandGroup (RepoName repo) (toGroup group)+parseSimCommand ("ungroup":repo:group:[]) =+	Right $ CommandUngroup (RepoName repo) (toGroup group)+parseSimCommand ("metadata":file:modmeta:[]) =+	Right $ CommandMetaData (toRawFilePath file) modmeta+parseSimCommand ("wanted":repo:expr) =+	Right $ CommandWanted (RepoName repo) (unwords expr)+parseSimCommand ("required":repo:expr) =+	Right $ CommandRequired (RepoName repo) (unwords expr)+parseSimCommand ("groupwanted":group:expr) =+	Right $ CommandGroupWanted (toGroup group) (unwords expr)+parseSimCommand ("randomwanted":repo:terms) =+	Right $ CommandRandomWanted (RepoName repo) terms+parseSimCommand ("randomrequired":repo:terms) =+	Right $ CommandRandomRequired (RepoName repo) terms+parseSimCommand ("randomgroupwanted":group:terms) =+	Right $ CommandRandomGroupWanted (toGroup group) terms+parseSimCommand ("maxsize":repo:size:[]) =+	case readSize dataUnits size of+		Just sz -> Right $ CommandMaxSize (RepoName repo) (MaxSize sz)+		Nothing -> Left $ "Unable to parse maxsize \"" ++ size ++ "\""+parseSimCommand ("clusternode":nodename:repo:[]) =+	Right $ CommandClusterNode (RepoName nodename) (RepoName repo)+parseSimCommand ("rebalance":onoff:[]) = case isTrueFalse onoff of+	Just b -> Right $ CommandRebalance b+	Nothing -> Left $ "Unable to parse rebalance value \"" ++ onoff ++ "\""+parseSimCommand ("visit":repo:cmdparams) =+	Right $ CommandVisit (RepoName repo) cmdparams+parseSimCommand ws = parseError ws++parseSimAction :: [String] -> Either String SimAction+parseSimAction ("action":repo:"pull":remote:rest) =+	mkAction rest $ ActionPull (RepoName repo) (RemoteName remote)+parseSimAction ("action":repo:"push":remote:rest) =+	mkAction rest $ ActionPush (RepoName repo) (RemoteName remote)+parseSimAction ("action":repo:"sync":remote:rest) =+	mkAction rest $ ActionSync (RepoName repo) (RemoteName remote)+parseSimAction ("action":repo:"getwanted":remote:rest) =+	mkAction rest $ ActionGetWanted (RepoName repo) (RemoteName remote)+parseSimAction ("action":repo:"sendwanted":remote:rest) =+	mkAction rest $ ActionSendWanted (RepoName repo) (RemoteName remote)+parseSimAction ("action":repo:"dropunwantedfrom":remote:rest) =+	mkAction rest $ ActionDropUnwanted (RepoName repo)+		(Just (RemoteName remote))+parseSimAction ("action":repo:"dropunwanted":rest) =+	mkAction rest $ ActionDropUnwanted (RepoName repo) Nothing+parseSimAction ("action":repo:"gitpush":remote:rest) =+	mkAction rest $ ActionGitPush (RepoName repo) (RemoteName remote)+parseSimAction ("action":repo:"gitpull":remote:rest) =+	mkAction rest $ ActionGitPull (RepoName repo) (RemoteName remote)+parseSimAction ws = parseError ws++mkAction :: [String] -> SimAction -> Either String SimAction+mkAction [] a = Right a+mkAction ("while":rest) a = case parseSimAction rest of+	Right b -> Right (ActionWhile a b)+	Left err -> Left err+mkAction ws _ = parseError ws++parseError :: [String] -> Either String a+parseError ws = Left $ "Unable to parse sim command: \"" ++ unwords ws ++ "\""++parseConnections :: [String] -> Either String Connections+parseConnections = go . reverse+  where+	go (r2:"->":r1:rest) = +		chain (RepoName r1 :-> RemoteName r2) rest+	go (r2:"<-":r1:rest) = +		chain (RemoteName r1 :<- RepoName r2) rest+	go (r2:"<->":r1:rest) = +		chain (RepoName r1 :<-> RepoName r2) rest+	go rest = bad rest++	chain c [] = Right c+	chain c ("->":r:rest) = chain (RepoName r :=> c) rest+	chain c ("<-":r:rest) = chain (RemoteName r :<= c) rest+	chain c ("<->":r:rest) = chain (RepoName r :<=> c) rest+	chain _ rest = bad rest++	bad rest = Left $ "Bad connect syntax near \"" ++ unwords rest ++ "\""++formatConnections :: Connections -> [String]+formatConnections (RepoName repo :-> RemoteName remote) =+	[repo, "->", remote]+formatConnections (RemoteName remote :<- RepoName repo) =+	[remote, "<-", repo]+formatConnections (RepoName repo1 :<-> RepoName repo2) =+	[repo1, "<->", repo2]+formatConnections (RepoName repo :=> c) =+	repo : "->" : formatConnections c+formatConnections (RemoteName remote :<= c) =+	remote : "<-" : formatConnections c+formatConnections (RepoName repo :<=> c) =+	repo : "<->" : formatConnections c+

Assistant/Gpg.hs view

@@ -9,10 +9,12 @@  import Utility.Gpg import Utility.UserInfo+import Utility.PartialPrelude import Types.Remote (RemoteConfigField) import Annex.SpecialRemote.Config import Types.ProposedAccepted +import Data.Maybe import qualified Data.Map as M import Control.Applicative import Prelude@@ -23,10 +25,11 @@ 	oldkeys <- secretKeys cmd 	username <- either (const "unknown") id <$> myUserName 	let basekeyname = username ++ "'s git-annex encryption key"-	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)-		( basekeyname-		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])-		)+	return $ fromMaybe (error "internal") $ headMaybe $+		filter (\n -> M.null $ M.filter (== n) oldkeys)+			( basekeyname+			: map (\n -> basekeyname ++ show n) ([2..] :: [Int])+			)  data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption 	deriving (Eq)

Assistant/WebApp/Pairing.hs view

@@ -35,8 +35,9 @@ addWormholePairingState :: WormholePairingHandle -> WormholePairingState -> IO WormholePairingId addWormholePairingState h tv = atomically $ do 	m <- readTVar tv-	-- use of head is safe because allids is infinite-	let i = Prelude.head $ filter (`notElem` M.keys m) allids+	-- safe because allids is infinite+	let i = fromMaybe (error "internal") $ +		headMaybe $ filter (`notElem` M.keys m) allids 	writeTVar tv (M.insert i h m) 	return i   where

Backend/Hash.hs view

@@ -9,13 +9,14 @@  module Backend.Hash ( 	backends,-	testKeyBackend, 	keyHash, 	descChecksum, 	Hash(..), 	cryptographicallySecure, 	hashFile,-	checkKeyChecksum+	checkKeyChecksum,+	testKeyBackend,+	genTestKey, ) where  import Annex.Common@@ -296,13 +297,25 @@  -} testKeyBackend :: Backend testKeyBackend = -	let b = genBackendE (SHA2Hash (HashSize 256))+	let b = genBackendE testKeyHash 	    gk = case genKey b of 		Nothing -> Nothing 		Just f -> Just (\ks p -> addTestE <$> f ks p) 	in b { genKey = gk }++addTestE :: Key -> Key+addTestE k = alterKey k $ \d -> d+	{ keyName = keyName d <> longext+	}   where-	addTestE k = alterKey k $ \d -> d-		{ keyName = keyName d <> longext-		} 	longext = ".this-is-a-test-key"++testKeyHash :: Hash+testKeyHash = SHA2Hash (HashSize 256)++genTestKey :: L.ByteString -> Key+genTestKey content = addTestE $ mkKey $ \kd -> kd+	{ keyName = S.toShort $ encodeBS $+		(fst $ hasher testKeyHash) content+	, keyVariety = backendVariety testKeyBackend+	}

Backend/VURL/Utilities.hs view

@@ -31,7 +31,8 @@   where 	-- Relies on the first hash being cryptographically secure, and the 	-- default hash used by git-annex.-	hashbackend = Prelude.head Backend.Hash.backends+	hashbackend = fromMaybe (error "internal") $ +		headMaybe Backend.Hash.backends  migrateFromVURLToURL :: Key -> Backend -> AssociatedFile -> Bool -> Annex (Maybe Key) migrateFromVURLToURL oldkey newbackend _af _

Backend/Variety.hs view

@@ -29,7 +29,7 @@  {- The default hashing backend. -} defaultHashBackend :: Backend-defaultHashBackend = Prelude.head regularBackendList+defaultHashBackend = fromMaybe (error "internal") $ headMaybe regularBackendList  makeVarietyMap :: [Backend] -> M.Map KeyVariety Backend makeVarietyMap l = M.fromList $ zip (map backendVariety l) l

CHANGELOG view

@@ -1,3 +1,19 @@+git-annex (10.20240927) upstream; urgency=medium++  * Detect when a preferred content expression contains "not present",+    which would lead to repeatedly getting and then dropping files,+    and make it never match. This also applies to +    "not balanced" and "not sizebalanced".+  * Fix --explain display of onlyingroup preferred content expression.+  * Allow maxsize to be set to 0 to stop checking maxsize for a repository.+  * Fix bug that prevented anything being stored in an empty+    repository whose preferred content expression uses sizebalanced.+  * sim: New command, can be used to simulate networks of repositories+    and see how preferred content and other configuration makes file+    content flow through it.++ -- Joey Hess <id@joeyh.name>  Mon, 30 Sep 2024 19:15:35 -0400+ git-annex (10.20240831) upstream; urgency=medium    * Special remotes configured with exporttree=yes annexobjects=yes

CmdLine.hs view

@@ -14,6 +14,7 @@  import qualified Options.Applicative as O import qualified Options.Applicative.Help as H+import qualified Data.List.NonEmpty as NE import Control.Exception (throw) import Control.Monad.IO.Class (MonadIO) import System.Exit@@ -91,7 +92,7 @@ 				handleresult (parseCmd progname progdesc correctedargs allcmds getparser) 			res -> handleresult res 	  where-		autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname cmds+		autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname (NE.fromList cmds) 		name 			| fuzzy = case cmds of 				(c:_) -> Just (cmdname c)

CmdLine/GitAnnex.hs view

@@ -132,6 +132,7 @@ import qualified Command.ExtendCluster import qualified Command.UpdateProxy import qualified Command.MaxSize+import qualified Command.Sim import qualified Command.Version import qualified Command.RemoteDaemon #ifdef WITH_ASSISTANT@@ -263,6 +264,7 @@ 	, Command.ExtendCluster.cmd 	, Command.UpdateProxy.cmd 	, Command.MaxSize.cmd+	, Command.Sim.cmd 	, Command.Version.cmd 	, Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT

CmdLine/Usage.hs view

@@ -96,6 +96,8 @@ paramTreeish = "TREEISH" paramParamValue :: String paramParamValue = "PARAM=VALUE"+paramCommand :: String+paramCommand = "COMMAND" paramNothing :: String paramNothing = "" paramRepeating :: String -> String

Command/FuzzTest.hs view

@@ -190,7 +190,7 @@  genFuzzAction :: Annex FuzzAction genFuzzAction = do-	tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)+	tmpl <- liftIO $ generate (arbitrary :: Gen FuzzAction) 	-- Fix up template action to make sense in the current repo tree. 	case tmpl of 		FuzzAdd _ -> do

Command/Info.hs view

@@ -40,7 +40,7 @@ import Git.Config (boolConfig) import qualified Git.LsTree as LsTree import Utility.Percentage-import Utility.Aeson hiding (json)+import Utility.Aeson import Types.Transfer import Logs.Transfer import Types.Key

+ Command/Sim.hs view

@@ -0,0 +1,97 @@+{- git-annex command+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Command.Sim where++import Command+import Annex.Sim+import Annex.Sim.File+import Annex.Perms++import System.Random++cmd :: Command+cmd = command "sim" SectionTesting+	"simulate a network of repositories"+	paramCommand (withParams seek)++seek :: CmdParams -> CommandSeek+seek ("start":[]) = startsim Nothing+seek ("start":simfile:[]) = startsim (Just simfile)+seek ("end":[]) = endsim+seek ("show":[]) = do+	simdir <- fromRepo gitAnnexSimDir+	liftIO (restoreSim simdir) >>= \case+		Left err -> giveup err+		Right st -> showsim st+seek ("run":simfile:[]) = startsim' (Just simfile) >>= cleanup+  where+	cleanup st = do +		st' <- liftIO $ quiesceSim st+		endsim+		when (simFailed st') $ do+			showsim st'+			giveup "Simulation shown above had errors."+seek ps = case parseSimCommand ps of+	Left err -> giveup err+	Right simcmd -> do+		repobyname <- mkGetExistingRepoByName+		simdir <- fromRepo gitAnnexSimDir+		liftIO (restoreSim simdir) >>= \case+			Left err -> giveup err+			Right st -> do+				st' <- runSimCommand simcmd repobyname st+				liftIO $ suspendSim st'+				when (simFailed st' && not (simFailed st)) $+					giveup "Simulation had errors."++startsim :: Maybe FilePath -> CommandSeek+startsim simfile = startsim' simfile >>= cleanup+  where+	cleanup st = do+		liftIO $ suspendSim st+		when (simFailed st) $+			giveup "Simulation had errors."++startsim' :: Maybe FilePath -> Annex (SimState SimRepo)+startsim' simfile = do+	simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir+	whenM (liftIO $ doesDirectoryExist simdir) $+		giveup "A sim was previously started. Use `git-annex sim end` to stop it before starting a new one."+	+	showLongNote $ UnquotedString "Sim started."+	rng <- liftIO $ fst . random <$> getStdGen+	let st = emptySimState rng simdir+	case simfile of+		Nothing -> startup simdir st []+		Just f -> liftIO (readFile f) >>= \c -> +			case parseSimFile c of+				Left err -> giveup err+				Right cs -> startup simdir st cs+  where+	startup simdir st cs = do+		repobyname <- mkGetExistingRepoByName+		createAnnexDirectory (toRawFilePath simdir)+		let st' = recordSeed st cs+		go st' repobyname cs++	go st _ [] = return st+	go st repobyname (c:cs) = do+		st' <- runSimCommand c repobyname st+		go st' repobyname cs+	+endsim :: CommandSeek+endsim = do+	simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir+	whenM (liftIO $ doesDirectoryExist simdir) $ do+		liftIO $ removeDirectoryRecursive simdir+	showLongNote $ UnquotedString "Sim ended."+		+showsim :: SimState SimRepo -> Annex ()+showsim = liftIO . putStr . generateSimFile . reverse . simHistory

Command/TestRemote.hs view

@@ -42,6 +42,7 @@ import qualified Data.Map as M import Data.Either import Control.Concurrent.STM hiding (check)+import qualified Data.List.NonEmpty as NE  cmd :: Command cmd = command "testremote" SectionTesting@@ -83,8 +84,10 @@ 			then giveup "This remote is readonly, so you need to use the --test-readonly option." 			else do 				showAction "generating test keys"-				mapM randKey (keySizes basesz fast)-		fs -> mapM (getReadonlyKey r . toRawFilePath) fs+				NE.fromList+					<$> mapM randKey (keySizes basesz fast)+		fs -> NE.fromList+			<$> mapM (getReadonlyKey r . toRawFilePath) fs 	let r' = if null (testReadonlyFile o) 		then r 		else r { Remote.readonly = True }@@ -100,7 +103,7 @@ 	basesz = fromInteger $ sizeOption o 	si = SeekInput [testRemote o] -perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform+perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> NE.NonEmpty Key -> CommandPerform perform drs unavailr exportr ks = do 	st <- liftIO . newTVarIO =<< (,) 		<$> Annex.getState id@@ -110,12 +113,12 @@ 		drs 		(pure unavailr) 		exportr-		(map (\k -> Described (desck k) (pure k)) ks)+		(NE.map (\k -> Described (desck k) (pure k)) ks) 	ok <- case tryIngredients [consoleTestReporter] mempty tests of 		Nothing -> error "No tests found!?" 		Just act -> liftIO act 	rs <- catMaybes <$> mapM getVal drs-	next $ cleanup rs ks ok+	next $ cleanup rs (NE.toList ks) ok   where 	desck k = unwords [ "key size", show (fromKey keySize k) ] @@ -216,12 +219,12 @@ 	-> [Described (Annex (Maybe Remote))] 	-> Annex (Maybe Remote) 	-> Annex (Maybe Remote)-	-> [Described (Annex Key)]+	-> (NE.NonEmpty (Described (Annex Key))) 	-> [TestTree] mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $-	[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (Prelude.head mkks))) ]-	, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- mkks, mkr <- mkrs ]-	, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 mkks, mkk2 <- take 2 (reverse mkks) ]+	[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]+	, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]+	, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ] 	]    where 	desc r k = intercalate "; " $ map unwords

Command/Uninit.hs view

@@ -79,7 +79,7 @@ 	 	current_branch =  		ifM (inRepo Git.Ref.headExists)-			( Just . Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead+			( headMaybe . map (Git.Ref . encodeBS) . lines . decodeBS <$> revhead 			, return Nothing 			) 	revhead = inRepo $ Git.Command.pipeReadStrict

Database/RepoSize.hs view

@@ -33,6 +33,7 @@ 	removeStaleLiveSizeChanges, 	recordedRepoOffsets, 	liveRepoOffsets,+	setSizeChanges, ) where  import Annex.Common@@ -310,6 +311,11 @@ 		(UniqueRepoRollingTotal u) 		(SizeChanges u sz) 		[SizeChangesRollingtotal =. sz]++setSizeChanges :: RepoSizeHandle -> M.Map UUID FileSize -> IO ()+setSizeChanges (RepoSizeHandle (Just h) _) sizemap = +	H.commitDb h $ forM_ (M.toList sizemap) $ uncurry setSizeChangeFor+setSizeChanges (RepoSizeHandle Nothing _) _ = noop  addRecentChange :: UUID -> Key -> SizeChange -> SqlPersistM () addRecentChange u k sc =

Git/AutoCorrect.hs view

@@ -15,6 +15,7 @@  import Text.EditDistance import Control.Concurrent+import qualified Data.List.NonEmpty as NE  {- These are the same cost values as used in git. -} gitEditCosts :: EditCosts@@ -44,7 +45,7 @@ {- Takes action based on git's autocorrect configuration, in preparation for  - an autocorrected command being run.  -}-prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()+prepare :: String -> (c -> String) -> NE.NonEmpty c -> Maybe Repo -> IO () prepare input showmatch matches r = 	case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of 		Just n@@ -57,7 +58,7 @@ 		[ "Unknown command '" ++ input ++ "'" 		, "" 		, "Did you mean one of these?"-		] ++ map (\m -> "\t" ++ showmatch m) matches+		] ++ map (\m -> "\t" ++ showmatch m) (NE.toList matches) 	warn :: Maybe Float -> IO () 	warn mdelaysec = hPutStr stderr $ unlines 		[ "WARNING: You called a git-annex command named '" ++@@ -67,7 +68,7 @@ 			Just sec -> "Continuing in " ++ show sec ++ " seconds, assuming that you meant " ++ match 		] 	  where-		match = "'" ++ showmatch (Prelude.head matches) ++ "'."+		match = "'" ++ showmatch (NE.head matches) ++ "'." 	sleep n = do 		warn (Just (fromIntegral n / 10 :: Float)) 		threadDelay (n * 100000) -- deciseconds to microseconds

Git/Config.hs view

@@ -12,6 +12,7 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.List.NonEmpty as NE import Data.Char import qualified System.FilePath.ByteString as P import Control.Concurrent.Async@@ -31,7 +32,7 @@  {- Returns a list of values. -} getList :: ConfigKey -> Repo -> [ConfigValue]-getList key repo = M.findWithDefault [] key (fullconfig repo)+getList key repo = maybe [] NE.toList $ M.lookup key (fullconfig repo)  {- Returns a single git config setting, if set. -} getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue@@ -118,7 +119,8 @@ 	val <- S.hGetContents h 	let c = parse val st 	debug (DebugSource "Git.Config") $ "git config read: " ++-		show (map (\(k, v) -> (show k, map show v)) (M.toList c))+		show (map (\(k, v) -> (show k, map show (NE.toList v))) +			(M.toList c)) 	storeParsed c repo  {- Stores a git config into a Repo, returning the new version of the Repo.@@ -128,10 +130,10 @@ store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo store s st = storeParsed (parse s st) -storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo+storeParsed :: M.Map ConfigKey (NE.NonEmpty ConfigValue) -> Repo -> IO Repo storeParsed c repo = updateLocation $ repo-	{ config = (M.map Prelude.head c) `M.union` config repo-	, fullconfig = M.unionWith (++) c (fullconfig repo)+	{ config = (M.map NE.head c) `M.union` config repo+	, fullconfig = M.unionWith (<>) c (fullconfig repo) 	}  {- Stores a single config setting in a Repo, returning the new version of@@ -139,7 +141,8 @@ store' :: ConfigKey -> ConfigValue -> Repo -> Repo store' k v repo = repo 	{ config = M.singleton k v `M.union` config repo-	, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)+	, fullconfig = M.unionWith (<>) (M.singleton k (v NE.:| []))+		(fullconfig repo) 	}  {- Updates the location of a repo, based on its configuration.@@ -191,7 +194,7 @@  {- Parses git config --list or git config --null --list output into a  - config map. -}-parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue]+parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey (NE.NonEmpty ConfigValue) parse s st 	| S.null s = M.empty 	| otherwise = case st of@@ -201,8 +204,8 @@ 	nl = fromIntegral (ord '\n') 	eq = fromIntegral (ord '=') -	sep c = M.fromListWith (++)-		. map (\(k,v) -> (ConfigKey k, [mkval v])) +	sep c = M.fromListWith (<>)+		. map (\(k,v) -> (ConfigKey k, mkval v NE.:| [])) 		. map (S.break (== c)) 	 	mkval v

Git/Remote.hs view

@@ -19,6 +19,7 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.List.NonEmpty as NE import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath@@ -117,7 +118,7 @@ 			(_, NoConfigValue) -> False 		filterconfig f = filter f $ 			concatMap splitconfigs $ M.toList $ fullconfig repo-		splitconfigs (k, vs) = map (\v -> (k, v)) vs+		splitconfigs (k, vs) = map (\v -> (k, v)) (NE.toList vs) 		(prefix, suffix) = ("url." , ".insteadof") 	-- git supports URIs that contain unescaped characters such as 	-- spaces. So to test if it's a (git) URI, escape those.

Git/Sha.hs view

@@ -13,6 +13,7 @@ import Git.Types  import qualified Data.ByteString as S+import qualified Data.List.NonEmpty as NE import Data.Char  {- Runs an action that causes a git subcommand to emit a Sha, and strips@@ -44,16 +45,15 @@ 		]  {- Sizes of git shas. -}-shaSizes :: [Int]+shaSizes :: NE.NonEmpty Int shaSizes = -	[ 40 -- sha1 (must come first)-	, 64 -- sha256-	]+	       40 -- sha1 (must come first)+	NE.:| [64] -- sha256  {- Git plumbing often uses a all 0 sha to represent things like a  - deleted file. -}-nullShas :: [Sha]-nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes+nullShas :: NE.NonEmpty Sha+nullShas = NE.map (\n -> Ref (S.replicate n zero)) shaSizes   where 	zero = fromIntegral (ord '0') @@ -63,7 +63,7 @@  - sha1 to the sha256, or probably just treat all null sha1 specially  - the same as all null sha256. -} deleteSha :: Sha-deleteSha = Prelude.head nullShas+deleteSha = NE.head nullShas  {- Git's magic empty tree.  -

Git/Types.hs view

@@ -14,6 +14,7 @@ import Data.Default import qualified Data.Map as M import qualified Data.ByteString as S+import qualified Data.List.NonEmpty as NE import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding@@ -42,7 +43,7 @@ 	{ location :: RepoLocation 	, config :: M.Map ConfigKey ConfigValue 	-- a given git config key can actually have multiple values-	, fullconfig :: M.Map ConfigKey [ConfigValue]+	, fullconfig :: M.Map ConfigKey (NE.NonEmpty ConfigValue) 	-- remoteName holds the name used for this repo in some other 	-- repo's list of remotes, when this repo is such a remote 	, remoteName :: Maybe RemoteName

Git/UnionMerge.hs view

@@ -107,9 +107,9 @@  - generating new content.  -} calcMerge :: [(Ref, [L8.ByteString])] -> Either Ref [L8.ByteString]-calcMerge shacontents-	| null reusable = Right new-	| otherwise = Left $ fst $ Prelude.head reusable+calcMerge shacontents = case reusable of+	[] -> Right new+	(r:_) -> Left $ fst r   where 	reusable = filter (\c -> sorteduniq (snd c) == new) shacontents 	new = sorteduniq $ concat $ map snd shacontents

Limit.hs view

@@ -69,7 +69,8 @@ 			Utility.Matcher.matchMrun' matcher $ \o -> 				matchAction o NoLiveUpdate S.empty i 		explain (mkActionItem i) $ UnquotedString <$>-			Utility.Matcher.describeMatchResult matchDesc desc+			Utility.Matcher.describeMatchResult+				(\o -> matchDesc o . Just) desc 				(if match then "matches:" else "does not match:") 		return match @@ -115,6 +116,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = "include" =? glob 	} @@ -130,6 +132,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = "exclude" =? glob 	} @@ -156,6 +159,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = "includesamecontent" =? glob 	} @@ -172,6 +176,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = "excludesamecontent" =? glob 	} @@ -249,6 +254,7 @@ 		, matchNeedsKey = False 		, matchNeedsLocationLog = False 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = False 		, matchDesc = limitname =? glob 		}   where@@ -277,6 +283,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple "unlocked" 	} @@ -288,6 +295,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple "locked" 	} @@ -324,6 +332,7 @@ 		, matchNeedsKey = True 		, matchNeedsLocationLog = not inhere 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = False 		, matchDesc = "in" =? s 		} 	checkinuuid u notpresent key@@ -355,6 +364,7 @@ 		, matchNeedsKey = True 		, matchNeedsLocationLog = True 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = True 		, matchDesc = matchDescSimple "expected-present" 		} @@ -373,6 +383,7 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = not (isNothing u) 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = True 	, matchDesc = matchDescSimple "present" 	} @@ -385,6 +396,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple desc 	}   where@@ -418,6 +430,7 @@ 			, matchNeedsKey = True 			, matchNeedsLocationLog = True 			, matchNeedsLiveRepoSize = False+			, matchNegationUnstable = False 			, matchDesc = "copies" =? want 			} 	go' n good notpresent key = do@@ -444,6 +457,7 @@ 		, matchNeedsKey = True 		, matchNeedsLocationLog = True 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = False 		, matchDesc = matchDescSimple desc 		} 	Nothing -> Left "bad value for number of lacking copies"@@ -475,6 +489,7 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple "unused" 	}   where@@ -499,6 +514,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple "anything" 	} @@ -515,6 +531,7 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple "nothing" 	} @@ -539,6 +556,7 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = True 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = "inallgroup" =? groupname 	}   where@@ -565,7 +583,8 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = True 	, matchNeedsLiveRepoSize = False-	, matchDesc = "inallgroup" =? groupname+	, matchNegationUnstable = False+	, matchDesc = "onlyingroup" =? groupname 	}   where 	check notpresent want key = do@@ -585,6 +604,7 @@ 		then groupname 		else groupname ++ ":1" 	let present = limitPresent mu+	let combo f = f present || f fullybalanced || f copies 	Right $ MatchFiles 		{ matchAction = \lu a i -> 			ifM (Annex.getRead Annex.rebalance)@@ -594,26 +614,16 @@ 						<&&> matchAction fullybalanced lu a i 					) 				)-		, matchNeedsFileName =-			matchNeedsFileName present ||-			matchNeedsFileName fullybalanced ||-			matchNeedsFileName copies-		, matchNeedsFileContent =-			matchNeedsFileContent present ||-			matchNeedsFileContent fullybalanced ||-			matchNeedsFileContent copies-		, matchNeedsKey =-			matchNeedsKey present ||-			matchNeedsKey fullybalanced ||-			matchNeedsKey copies-		, matchNeedsLocationLog =-			matchNeedsLocationLog present ||-			matchNeedsLocationLog fullybalanced ||-			matchNeedsLocationLog copies+		, matchNeedsFileName = combo matchNeedsFileName+		, matchNeedsFileContent = combo matchNeedsFileContent+		, matchNeedsKey = combo matchNeedsKey+		, matchNeedsLocationLog = combo matchNeedsLocationLog 		, matchNeedsLiveRepoSize = True+		, matchNegationUnstable = combo matchNegationUnstable 		, matchDesc = termname =? groupname 		} + limitFullyBalanced :: Maybe UUID -> Annex GroupMap -> MkLimit Annex limitFullyBalanced = limitFullyBalanced' "fullybalanced" @@ -624,6 +634,7 @@ 	threshhold <- annexFullyBalancedThreshhold <$> Annex.getGitConfig 	let toofull u = 		case (M.lookup u maxsizes, M.lookup u sizemap) of+			(Just (MaxSize 0), _) -> False 			(Just (MaxSize maxsize), Just (RepoSize reposize)) -> 				fromIntegral reposize >= fromIntegral maxsize * threshhold 			_ -> False@@ -697,6 +708,7 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = True+	, matchNegationUnstable = False 	, matchDesc = termname =? want 	} @@ -724,8 +736,8 @@ filterCandidatesFullySizeBalanced maxsizes sizemap n key candidates = do 	currentlocs <- S.fromList <$> loggedLocations key  	let keysize = fromMaybe 0 (fromKey keySize key)-	let go u = case (M.lookup u maxsizes, M.lookup u sizemap, u `S.member` currentlocs) of-		(Just maxsize, Just reposize, inrepo)+	let go u = case (M.lookup u maxsizes, fromMaybe (RepoSize 0) (M.lookup u sizemap), u `S.member` currentlocs) of+		(Just maxsize, reposize, inrepo) 			| repoHasSpace keysize inrepo reposize maxsize -> 				proportionfree keysize inrepo u reposize maxsize 			| otherwise -> Nothing@@ -757,6 +769,7 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = "inbackend" =? name 	}   where@@ -775,6 +788,7 @@ 	, matchNeedsKey = True 	, matchNeedsLocationLog = False 	, matchNeedsLiveRepoSize = False+	, matchNegationUnstable = False 	, matchDesc = matchDescSimple "securehash" 	} @@ -797,6 +811,7 @@ 		, matchNeedsKey = False 		, matchNeedsLocationLog = False 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = False 		, matchDesc = desc =? s 		}   where@@ -828,6 +843,7 @@ 		, matchNeedsKey = True 		, matchNeedsLocationLog = False 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = False 		, matchDesc = "metadata" =? s 		}   where@@ -845,6 +861,7 @@ 		, matchNeedsKey = False 		, matchNeedsLocationLog = False 		, matchNeedsLiveRepoSize = False+		, matchNegationUnstable = False 		, matchDesc = "accessedwithin" =? fromDuration duration 		}   where@@ -866,9 +883,10 @@ checkKey a (MatchingInfo p) = maybe (return False) a (providedKey p) checkKey a (MatchingUserInfo p) = a =<< getUserInfo (userProvidedKey p) -matchDescSimple :: String -> (Bool -> Utility.Matcher.MatchDesc)-matchDescSimple s b = Utility.Matcher.MatchDesc $ s +++matchDescSimple :: String -> (Maybe Bool -> Utility.Matcher.MatchDesc)+matchDescSimple s (Just b) = Utility.Matcher.MatchDesc $ s ++ 	if b then "[TRUE]" else "[FALSE]"+matchDescSimple s Nothing = Utility.Matcher.MatchDesc s -(=?) :: String -> String -> (Bool -> Utility.Matcher.MatchDesc)+(=?) :: String -> String -> (Maybe Bool -> Utility.Matcher.MatchDesc) k =? v = matchDescSimple (k ++ "=" ++ v)

Limit/Wanted.hs view

@@ -41,6 +41,7 @@ 	nk <- introspectPreferredRequiredContent matchNeedsKey Nothing 	nl <- introspectPreferredRequiredContent matchNeedsLocationLog Nothing 	lsz <- introspectPreferredRequiredContent matchNeedsLiveRepoSize Nothing+	nu <- introspectPreferredRequiredContent matchNegationUnstable Nothing 	addLimit $ Right $ MatchFiles 		{ matchAction = const $ const a 		, matchNeedsFileName = nfn@@ -48,6 +49,7 @@ 		, matchNeedsKey = nk 		, matchNeedsLocationLog = nl 		, matchNeedsLiveRepoSize = lsz+		, matchNegationUnstable = nu 		, matchDesc = matchDescSimple desc 		}

Logs/MaxSize.hs view

@@ -39,6 +39,7 @@ 		(buildLogNew buildMaxSize) 			. changeLog c uuid maxsize 			. parseLogNew parseMaxSize+	Annex.changeState $ \s -> s { Annex.maxsizes = Nothing }  buildMaxSize :: MaxSize -> Builder buildMaxSize (MaxSize n) = byteString (encodeBS (show n))

Logs/NumCopies.hs view

@@ -36,12 +36,14 @@ 	curr <- getGlobalNumCopies 	when (curr /= Just new) $ 		setLog (Annex.Branch.RegardingUUID []) numcopiesLog new+	Annex.changeState $ \s -> s { Annex.globalnumcopies = Nothing }  setGlobalMinCopies :: MinCopies -> Annex () setGlobalMinCopies new = do 	curr <- getGlobalMinCopies 	when (curr /= Just new) $ 		setLog (Annex.Branch.RegardingUUID []) mincopiesLog new+	Annex.changeState $ \s -> s { Annex.globalmincopies = Nothing }  {- Value configured in the numcopies log. Cached for speed. -} getGlobalNumCopies :: Annex (Maybe NumCopies)

Logs/PreferredContent.hs view

@@ -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 @@ 	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 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 @@ 	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 @@ 	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. -}-makeMatcher-	:: GroupMap-	-> 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+ - versions of git-annex may add new features.+ -+ - 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.  -@@ -164,22 +127,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

Logs/PreferredContent/Raw.hs view

@@ -23,10 +23,14 @@  {- Changes the preferred content configuration of a remote. -} preferredContentSet :: UUID -> PreferredContentExpression -> Annex ()-preferredContentSet = setLog preferredContentLog+preferredContentSet u expr = do+	setLog preferredContentLog u expr+	Annex.changeState $ \st -> st { Annex.preferredcontentmap = Nothing }  requiredContentSet :: UUID -> PreferredContentExpression -> Annex ()-requiredContentSet = setLog requiredContentLog+requiredContentSet u expr = do+	setLog requiredContentLog u expr+	Annex.changeState $ \st -> st { Annex.requiredcontentmap = Nothing }  setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do

Logs/UUID.hs view

@@ -39,6 +39,7 @@ 	c <- currentVectorClock 	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) uuidLog $ 		buildLogOld builder . changeLog c uuid desc . parseUUIDLog+	Annex.changeState $ \s -> s { Annex.uuiddescmap = Nothing }   where 	builder (UUIDDesc b) = byteString (escnewline b) 	-- Escape any newline in the description, since newlines cannot

Remote.hs view

@@ -52,6 +52,7 @@ 	remoteLocations, 	nameToUUID, 	nameToUUID',+	nameToUUID'', 	showTriedRemotes, 	listRemoteNames, 	showLocations,@@ -148,8 +149,11 @@ 		| otherwise = return $ Just r  byName' :: RemoteName -> Annex (Either String Remote)-byName' "" = return $ Left "no repository name specified"-byName' n = go . filter matching <$> remoteList+byName' n = byName'' n <$> remoteList++byName'' :: RemoteName -> [Remote] -> Either String Remote+byName'' "" _ = Left "no repository name specified"+byName'' n remotelist = go $ filter matching remotelist   where 	go [] = Left $ "there is no available git remote named \"" ++ n ++ "\"" 	go (match:_) = Right match@@ -182,20 +186,31 @@ 	(_, msg) -> giveup msg  nameToUUID' :: RemoteName -> Annex ([UUID], String)-nameToUUID' n+nameToUUID' n = do+	f <- nameToUUID''+	return (f n)++nameToUUID'' :: Annex (RemoteName -> ([UUID], String))+nameToUUID'' = do+	l <- remoteList+	u <- getUUID+	m <- uuidDescMap+	return $ \n -> nameToUUID''' n l u m++nameToUUID''' :: RemoteName -> [Remote] -> UUID -> UUIDDescMap -> ([UUID], String)+nameToUUID''' n remotelist hereu m 	| n == "." = currentrepo 	| n == "here" = currentrepo-	| otherwise = byName' n >>= go+	| otherwise = go (byName'' n remotelist)   where-	currentrepo = mkone <$> getUUID+	currentrepo = mkone hereu -	go (Right r) = return $ case uuid r of+	go (Right r) = case uuid r of 		NoUUID -> ([], noRemoteUUIDMsg r) 		u -> mkone u-	go (Left e) = do-		m <- uuidDescMap+	go (Left e) = 		let descn = UUIDDesc (encodeBS n)-		return $ case M.keys (M.filter (== descn) m) of+		in case M.keys (M.filter (== descn) m) of 			[] ->  				let u = toUUID n 				in case M.keys (M.filterWithKey (\k _ -> k == u) m) of@@ -458,7 +473,8 @@ claimingUrl' :: (Remote -> Bool) -> URLString -> Annex Remote claimingUrl' remotefilter url = do 	rs <- remoteList-	let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs+	let web = fromMaybe (error "internal") $ headMaybe $+		filter (\r -> uuid r == webUUID) rs 	fromMaybe web <$> firstM checkclaim (filter remotefilter rs)   where 	checkclaim = maybe (pure False) (`id` url) . claimUrl

Remote/Bup.hs view

@@ -307,7 +307,7 @@ 	| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir   where 	bits = splitc ':' r-	host = Prelude.head bits+	host = fromMaybe "" $ headMaybe bits 	dir = intercalate ":" $ drop 1 bits 	-- "host:~user/dir" is not supported specially by bup; 	-- "host:dir" is relative to the home directory;

Remote/Directory.hs view

@@ -17,6 +17,7 @@  import qualified Data.ByteString.Lazy as L import qualified Data.Map as M+import qualified Data.List.NonEmpty as NE import qualified System.FilePath.ByteString as P import Data.Default import System.PosixCompat.Files (isRegularFile, deviceID)@@ -166,17 +167,21 @@ {- Locations to try to access a given Key in the directory.  - We try more than one since we used to write to different hash  - directories. -}-locations :: RawFilePath -> Key -> [RawFilePath]-locations d k = map (d P.</>) (keyPaths k)+locations :: RawFilePath -> Key -> NE.NonEmpty RawFilePath+locations d k = NE.map (d P.</>) (keyPaths k) +locations' :: RawFilePath -> Key -> [RawFilePath]+locations' d k = NE.toList (locations d k)+ {- Returns the location off a Key in the directory. If the key is  - present, returns the location that is actually used, otherwise  - returns the first, default location. -} getLocation :: RawFilePath -> Key -> IO RawFilePath getLocation d k = do 	let locs = locations d k-	fromMaybe (Prelude.head locs)-		<$> firstM (doesFileExist . fromRawFilePath) locs+	fromMaybe (NE.head locs)+		<$> firstM (doesFileExist . fromRawFilePath)+			(NE.toList locs)  {- Directory where the file(s) for a key are stored. -} storeDir :: RawFilePath -> Key -> RawFilePath@@ -246,7 +251,7 @@ 	dest' = fromRawFilePath dest  retrieveKeyFileM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Retriever-retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations d+retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations' d retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do 	src <- liftIO $ fromRawFilePath <$> getLocation d k 	void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv@@ -311,8 +316,8 @@ 		goparents (upFrom subdir) =<< tryIO (removeDirectory d)  checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent-checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k-checkPresentM d _ k = checkPresentGeneric d (locations d k)+checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k+checkPresentM d _ k = checkPresentGeneric d (locations' d k)  checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool checkPresentGeneric d ps = checkPresentGeneric' d $

Remote/Git.hs view

@@ -72,6 +72,7 @@ import Control.Concurrent import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.List.NonEmpty as NE import qualified Data.ByteString as B import qualified Utility.RawFilePath as R import Network.URI@@ -937,7 +938,7 @@ 				Git.fullconfig r 			in r  				{ Git.remoteName = Just proxyname-				, Git.config = M.map Prelude.head c+				, Git.config = M.map NE.head c 				, Git.fullconfig = c 				} 		@@ -948,19 +949,21 @@ 				adjustclusternode clusters $ 				inheritconfigs $ Git.fullconfig r' 			in r'-				{ Git.config = M.map Prelude.head c+				{ Git.config = M.map NE.head c 				, Git.fullconfig = c 				} -		adduuid ck = M.insert ck-			[Git.ConfigValue $ fromUUID $ proxyRemoteUUID p]+		adduuid ck = M.insert ck $ +			(Git.ConfigValue $ fromUUID $ proxyRemoteUUID p)+				NE.:| [] -		addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField))-			[Git.ConfigValue $ encodeBS $ Git.repoLocation r]+		addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField)) $+			(Git.ConfigValue $ encodeBS $ Git.repoLocation r)+				NE.:| [] 		 		addproxiedby = case remoteAnnexUUID gc of 			Just u -> addremoteannexfield ProxiedByField-				[Git.ConfigValue $ fromUUID u]+				(Git.ConfigValue $ fromUUID u) 			Nothing -> id 		 		-- A node of a cluster that is being proxied along with@@ -975,15 +978,16 @@ 				Just cs 					| any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) -> 						addremoteannexfield SyncField-							[Git.ConfigValue $ Git.Config.boolConfig' False]+							(Git.ConfigValue $ Git.Config.boolConfig' False) 						. addremoteannexfield CostField -							[Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1]+							(Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1) 				_ -> id  		proxieduuids = S.map proxyRemoteUUID proxied  		addremoteannexfield f = M.insert-			(mkRemoteConfigKey renamedr (remoteGitConfigKey f))+			(mkRemoteConfigKey renamedr (remoteGitConfigKey f)) +			. (\v -> v NE.:| [])  		inheritconfigs c = foldl' inheritconfig c proxyInheritedFields

Remote/Helper/AWS.hs view

@@ -40,7 +40,7 @@ regionMap = M.fromList . regionInfo  defaultRegion :: Service -> Region-defaultRegion = snd . Prelude.head . regionInfo+defaultRegion = snd . fromMaybe (error "internal") . headMaybe . regionInfo  data ServiceRegion = BothRegion Region | S3Region Region | GlacierRegion Region

Remote/Rsync.hs view

@@ -51,6 +51,7 @@ import qualified Utility.RawFilePath as R  import qualified Data.Map as M+import qualified Data.List.NonEmpty as NE  remote :: RemoteType remote = specialRemoteType $ RemoteType@@ -222,7 +223,7 @@ store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex () store o k src meterupdate = storeGeneric o meterupdate basedest populatedest   where-	basedest = fromRawFilePath $ Prelude.head (keyPaths k)+	basedest = fromRawFilePath $ NE.head (keyPaths k) 	populatedest dest = liftIO $ if canrename 		then do 			R.rename (toRawFilePath src) (toRawFilePath dest)

Remote/Rsync/RsyncUrl.hs view

@@ -22,6 +22,7 @@  import Data.Default import System.FilePath.Posix+import qualified Data.List.NonEmpty as NE  type RsyncUrl = String @@ -42,7 +43,7 @@ mkRsyncUrl o f = rsyncUrl o </> rsyncEscape o f  rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl]-rsyncUrls o k = map use dirHashes+rsyncUrls o k = map use (NE.toList dirHashes)   where 	use h = rsyncUrl o </> hash h </> rsyncEscape o (f </> f) 	f = fromRawFilePath (keyFile k)

Test.hs view

@@ -23,11 +23,12 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy.UTF8 as BU8 import Control.Concurrent.STM hiding (check)+import qualified Utility.RawFilePath as R+import qualified Data.List.NonEmpty as NE+import Data.String  import Common import CmdLine.GitAnnex.Options-import qualified Utility.RawFilePath as R-import Data.String  import qualified Utility.ShellEscape import qualified Annex@@ -251,7 +252,7 @@ 			cv <- annexeval cache 			liftIO $ atomically $ putTMVar v 				(r, (unavailr, (exportr, (ks, cv))))-	go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks+	go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr (NE.fromList mkks) 	  where 		runannex = inmainrepo . annexeval 		mkrs = if testvariants@@ -1939,9 +1940,9 @@ 		checkFile mvariant filename = 			Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) filename $ 				if mvariant == Just Types.Crypto.PubKey then ks else Nothing-		serializeKeys cipher = map fromRawFilePath . -			Annex.Locations.keyPaths .-			Crypto.encryptKey Types.Crypto.HmacSha1 cipher+		serializeKeys cipher = map fromRawFilePath . NE.toList +			. Annex.Locations.keyPaths+			. Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else test_gpg_crypto = putStrLn "gpg testing not implemented on Windows" #endif

Types/Difference.hs view

@@ -1,6 +1,6 @@ {- git-annex repository differences  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -32,7 +32,7 @@ import qualified Data.Semigroup as Sem import Prelude --- Describes differences from the v5 repository format.+-- Describes differences from the standard repository format. -- -- The serialization is stored in difference.log, so avoid changes that -- would break compatibility.@@ -51,6 +51,7 @@ 	= ObjectHashLower 	| OneLevelObjectHash 	| OneLevelBranchHash+	| Simulation 	deriving (Show, Read, Eq, Ord, Enum, Bounded)  -- This type is used internally for efficient checking for differences,@@ -60,6 +61,7 @@ 		{ objectHashLower :: Bool 		, oneLevelObjectHash :: Bool 		, oneLevelBranchHash :: Bool+		, simulation :: Bool 		} 	| UnknownDifferences @@ -71,6 +73,7 @@ 		[ objectHashLower 		, oneLevelObjectHash 		, oneLevelBranchHash+		, simulation 		]  appendDifferences :: Differences -> Differences -> Differences@@ -78,6 +81,7 @@ 	{ objectHashLower = objectHashLower a || objectHashLower b 	, oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b 	, oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b+	, simulation = simulation a || simulation b 	} appendDifferences _ _ = UnknownDifferences @@ -85,7 +89,7 @@ 	(<>) = appendDifferences  instance Monoid Differences where-	mempty = Differences False False False+	mempty = Differences False False False False  readDifferences :: String -> Differences readDifferences = maybe UnknownDifferences mkDifferences . readish@@ -97,26 +101,28 @@ getDifferences r = mkDifferences $ S.fromList $ 	mapMaybe getmaybe [minBound .. maxBound]   where-	getmaybe d = case Git.Config.isTrueFalse' =<< Git.Config.getMaybe (differenceConfigKey d) r of+	getmaybe d = case Git.Config.isTrueFalse' =<< flip Git.Config.getMaybe r =<< differenceConfigKey d of 		Just True -> Just d 		_ -> Nothing -differenceConfigKey :: Difference -> ConfigKey+differenceConfigKey :: Difference -> Maybe ConfigKey differenceConfigKey ObjectHashLower = tunable "objecthashlower" differenceConfigKey OneLevelObjectHash = tunable "objecthash1" differenceConfigKey OneLevelBranchHash = tunable "branchhash1"+differenceConfigKey Simulation = Nothing  differenceConfigVal :: Difference -> String differenceConfigVal _ = Git.Config.boolConfig True -tunable :: B.ByteString -> ConfigKey-tunable k = ConfigKey ("annex.tune." <> k)+tunable :: B.ByteString -> Maybe ConfigKey+tunable k = Just $ ConfigKey ("annex.tune." <> k)  hasDifference :: Difference -> Differences -> Bool hasDifference _ UnknownDifferences = False hasDifference ObjectHashLower ds = objectHashLower ds hasDifference OneLevelObjectHash ds = oneLevelObjectHash ds hasDifference OneLevelBranchHash ds = oneLevelBranchHash ds+hasDifference Simulation ds = simulation ds  listDifferences :: Differences -> [Difference] listDifferences d@(Differences {}) = map snd $@@ -124,6 +130,7 @@ 		[ (objectHashLower, ObjectHashLower) 		, (oneLevelObjectHash, OneLevelObjectHash) 		, (oneLevelBranchHash, OneLevelBranchHash)+		, (simulation, Simulation) 		] listDifferences UnknownDifferences = [] @@ -132,6 +139,7 @@ 	{ objectHashLower = check ObjectHashLower 	, oneLevelObjectHash = check OneLevelObjectHash 	, oneLevelBranchHash = check OneLevelBranchHash+	, simulation = check Simulation 	}   where 	check f = f `S.member` s

Types/FileMatcher.hs view

@@ -98,7 +98,9 @@ 	-- ^ does the matchAction look at the location log? 	, matchNeedsLiveRepoSize :: Bool 	-- ^ does the matchAction need live repo size information?-	, matchDesc :: Bool -> MatchDesc+	, matchNegationUnstable :: Bool+	-- ^ does negating the matchAction lead to unstable behavior?+	, matchDesc :: Maybe Bool -> MatchDesc 	-- ^ displayed to the user to describe whether it matched or not 	}

Types/Group.hs view

@@ -22,7 +22,7 @@ import qualified Data.ByteString as S  newtype Group = Group S.ByteString-	deriving (Eq, Ord, Show)+	deriving (Eq, Ord, Show, Read)  fromGroup :: Group -> String fromGroup (Group g) = decodeBS g

Types/Key.hs view

@@ -68,7 +68,7 @@ data Key = MkKey 	{ keyData :: KeyData 	, keySerialization :: S.ShortByteString-	} deriving (Show, Generic)+	} deriving (Show, Read, Generic)  instance Eq Key where 	-- comparing the serialization would be unnecessary work

Types/MetaData.hs view

@@ -62,7 +62,7 @@ import qualified Data.ByteString.Char8 as B8  newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))-	deriving (Show, Eq, Ord)+	deriving (Read, Show, Eq, Ord)  instance ToJSON' MetaData where 	toJSON' (MetaData m) = object $ map go (M.toList m)

Types/NumCopies.hs view

@@ -26,6 +26,8 @@ 	mkSafeDropProof, 	ContentRemovalLock(..), 	p2pDefaultLockContentRetentionDuration,+	safeDropAnalysis,+	SafeDropAnalysis(..), ) where  import Types.UUID@@ -42,7 +44,7 @@ import Data.Time.Clock.POSIX (POSIXTime)  newtype NumCopies = NumCopies Int-	deriving (Ord, Eq, Show)+	deriving (Ord, Eq, Show, Read)  -- Smart constructor; prevent configuring numcopies to 0 which would -- cause data loss.@@ -55,7 +57,7 @@ fromNumCopies (NumCopies n) = n  newtype MinCopies = MinCopies Int-	deriving (Ord, Eq, Show)+	deriving (Ord, Eq, Show, Read)  configuredMinCopies :: Int -> MinCopies configuredMinCopies n

Types/RepoSize.hs view

@@ -26,11 +26,11 @@  -- The maximum size of a repo. newtype MaxSize = MaxSize { fromMaxSize :: Integer }-	deriving (Show, Eq, Ord)+	deriving (Show, Read, Eq, Ord)  -- An offset to the size of a repo.-newtype SizeOffset = SizeOffset { fromSizeChange :: Integer }-	deriving (Show, Eq, Ord, Num)+newtype SizeOffset = SizeOffset { fromSizeOffset :: Integer }+	deriving (Show, Read, Eq, Ord, Num)  -- Used when an action is in progress that will change the current size of -- a repository.

Types/TrustLevel.hs view

@@ -22,7 +22,7 @@ import Types.UUID  data TrustLevel = DeadTrusted | UnTrusted | SemiTrusted | Trusted-	deriving (Eq, Enum, Ord, Bounded, Show)+	deriving (Eq, Enum, Ord, Bounded, Show, Read)  instance Default TrustLevel  where 	def = SemiTrusted

Upgrade/V1.hs view

@@ -167,7 +167,7 @@ 		}   where 	bits = splitc ':' v-	b = Prelude.head bits+	b = fromMaybe (error "unable to parse v0 key") (headMaybe bits) 	n = intercalate ":" $ drop (if wormy then 3 else 1) bits 	t = if wormy 		then readMaybe (bits !! 1) :: Maybe EpochTime

Utility/Aeson.hs view

@@ -18,11 +18,7 @@ 	textKey, ) where -#if MIN_VERSION_aeson(2,0,0)-import Data.Aeson as X hiding (ToJSON, toJSON, encode, Key)-#else-import Data.Aeson as X hiding (ToJSON, toJSON, encode)-#endif+import Data.Aeson as X (decode, eitherDecode, parseJSON, FromJSON, Object, object, Value(..), (.=), (.:), (.:?)) import Data.Aeson hiding (encode) import qualified Data.Aeson #if MIN_VERSION_aeson(2,0,0)

Utility/DataUnits.hs view

@@ -180,16 +180,16 @@  {- Parses strings like "10 kilobytes" or "0.5tb". -} readSize :: [Unit] -> String -> Maybe ByteSize-readSize units input-	| null parsednum || null parsedunit = Nothing-	| otherwise = Just $ round $ number * fromIntegral multiplier+readSize units input = case parsednum of+	[] -> Nothing+	((number, rest):_) ->+		let unitname = takeWhile isAlpha $ dropWhile isSpace rest+		in case lookupUnit units unitname of+			[] -> Nothing+			(multiplier:_) -> +				Just $ round $ number * fromIntegral multiplier   where-	(number, rest) = head parsednum-	multiplier = head parsedunit-	unitname = takeWhile isAlpha $ dropWhile isSpace rest- 	parsednum = reads input :: [(Double, String)]-	parsedunit = lookupUnit units unitname  	lookupUnit _ [] = [1] -- no unit given, assume bytes 	lookupUnit [] _ = []

Utility/Matcher.hs view

@@ -31,6 +31,7 @@ 	matchMrun, 	matchMrun', 	isEmpty,+	findNegated, 	combineMatchers, 	introspect, 	describeMatchResult,@@ -54,7 +55,7 @@ 	| MOp op 	deriving (Show, Eq, Foldable) -newtype MatchDesc = MatchDesc String+newtype MatchDesc = MatchDesc { fromMatchDesc :: String }  data MatchResult op 	= MatchedOperation Bool op@@ -222,6 +223,19 @@ isEmpty :: Matcher a -> Bool isEmpty MAny = True isEmpty _ = False++{- Finds terms within the matcher that are negated.+ - Terms that are doubly negated are not returned. -}+findNegated :: Matcher op -> [op]+findNegated = go False []+  where+	go _ c MAny = c+	go n c (MAnd a b) = go n (go n c a) b+	go n c (MOr a b) = go n (go n c a) b+	go n c (MNot m) = go (not n) c m+	go n c (MOp o)+		| n = (o:c)+		| otherwise = c  {- Combines two matchers, yielding a matcher that will match anything  - both do. But, if one matcher contains no limits, yield the other one. -}

Utility/Misc.hs view

@@ -52,9 +52,8 @@ separate :: (a -> Bool) -> [a] -> ([a], [a]) separate c l = unbreak $ break c l   where-	unbreak r@(a, b)-		| null b = r-		| otherwise = (a, tail b)+	unbreak (a, (_:b)) = (a, b)+	unbreak r = r  separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) separate' c l = unbreak $ S.break c l

Utility/PartialPrelude.hs view

@@ -9,8 +9,6 @@  module Utility.PartialPrelude ( 	Utility.PartialPrelude.read,-	Utility.PartialPrelude.head,-	Utility.PartialPrelude.tail, 	Utility.PartialPrelude.init, 	Utility.PartialPrelude.last, 	Utility.PartialPrelude.readish,@@ -26,16 +24,6 @@  - Instead, use: readish -} read :: Read a => String -> a read = Prelude.read--{- head is a partial function; head [] is an error- - Instead, use: take 1 or headMaybe -}-head :: [a] -> a-head = Prelude.head--{- tail is also partial- - Instead, use: drop 1 -}-tail :: [a] -> [a]-tail = Prelude.tail  {- init too  - Instead, use: beginning -}

Utility/Tor.hs view

@@ -80,7 +80,7 @@ 		((p, _s):_) -> waithiddenservice 1 p 		_ -> do 			highports <- R.getStdRandom mkhighports-			let newport = Prelude.head $+			let newport = fromMaybe (error "internal") $ headMaybe $ 				filter (`notElem` map fst portssocks) highports 			torrc <- findTorrc 			writeFile torrc $ unlines $

git-annex.cabal view

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20240831+Version: 10.20240927 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -577,6 +577,8 @@     Annex.RepoSize     Annex.RepoSize.LiveUpdate     Annex.SafeDropProof+    Annex.Sim+    Annex.Sim.File     Annex.SpecialRemote     Annex.SpecialRemote.Config     Annex.Ssh@@ -732,6 +734,7 @@     Command.SendKey     Command.SetKey     Command.SetPresentKey+    Command.Sim     Command.Smudge     Command.Status     Command.Sync