diff --git a/Annex/Difference.hs b/Annex/Difference.hs --- a/Annex/Difference.hs +++ b/Annex/Difference.hs @@ -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 diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -1,4 +1,4 @@ -{- git-annex file locations +{- git-annex object file locations - - Copyright 2010-2019 Joey Hess - @@ -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 diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -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 + } diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -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 diff --git a/Annex/Sim.hs b/Annex/Sim.hs new file mode 100644 --- /dev/null +++ b/Annex/Sim.hs @@ -0,0 +1,1404 @@ +{- git-annex simulator + - + - Copyright 2024 Joey Hess + - + - 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 } + } diff --git a/Annex/Sim/File.hs b/Annex/Sim/File.hs new file mode 100644 --- /dev/null +++ b/Annex/Sim/File.hs @@ -0,0 +1,284 @@ +{- sim files + - + - Copyright 2024 Joey Hess + - + - 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 + diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs --- a/Assistant/Gpg.hs +++ b/Assistant/Gpg.hs @@ -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) diff --git a/Assistant/WebApp/Pairing.hs b/Assistant/WebApp/Pairing.hs --- a/Assistant/WebApp/Pairing.hs +++ b/Assistant/WebApp/Pairing.hs @@ -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 diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -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 + } diff --git a/Backend/VURL/Utilities.hs b/Backend/VURL/Utilities.hs --- a/Backend/VURL/Utilities.hs +++ b/Backend/VURL/Utilities.hs @@ -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 _ diff --git a/Backend/Variety.hs b/Backend/Variety.hs --- a/Backend/Variety.hs +++ b/Backend/Variety.hs @@ -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 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 Mon, 30 Sep 2024 19:15:35 -0400 + git-annex (10.20240831) upstream; urgency=medium * Special remotes configured with exporttree=yes annexobjects=yes diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -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) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -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 diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -96,6 +96,8 @@ paramTreeish = "TREEISH" paramParamValue :: String paramParamValue = "PARAM=VALUE" +paramCommand :: String +paramCommand = "COMMAND" paramNothing :: String paramNothing = "" paramRepeating :: String -> String diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -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 diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -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 diff --git a/Command/Sim.hs b/Command/Sim.hs new file mode 100644 --- /dev/null +++ b/Command/Sim.hs @@ -0,0 +1,97 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - 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 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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 diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -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 diff --git a/Database/RepoSize.hs b/Database/RepoSize.hs --- a/Database/RepoSize.hs +++ b/Database/RepoSize.hs @@ -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 = diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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 diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -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. diff --git a/Git/Sha.hs b/Git/Sha.hs --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -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. - diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -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 diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -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 diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -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) diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -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 } diff --git a/Logs/MaxSize.hs b/Logs/MaxSize.hs --- a/Logs/MaxSize.hs +++ b/Logs/MaxSize.hs @@ -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)) diff --git a/Logs/NumCopies.hs b/Logs/NumCopies.hs --- a/Logs/NumCopies.hs +++ b/Logs/NumCopies.hs @@ -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) diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration - - - Copyright 2012-2023 Joey Hess + - Copyright 2012-2024 Joey Hess - - 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 diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -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 diff --git a/Logs/UUID.hs b/Logs/UUID.hs --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -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 diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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; diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 $ diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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) diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -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) diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/Types/Difference.hs b/Types/Difference.hs --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -1,6 +1,6 @@ {- git-annex repository differences - - - Copyright 2015 Joey Hess + - Copyright 2015-2024 Joey Hess - - 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 diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -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 } diff --git a/Types/Group.hs b/Types/Group.hs --- a/Types/Group.hs +++ b/Types/Group.hs @@ -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 diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -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 diff --git a/Types/MetaData.hs b/Types/MetaData.hs --- a/Types/MetaData.hs +++ b/Types/MetaData.hs @@ -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) diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -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 diff --git a/Types/RepoSize.hs b/Types/RepoSize.hs --- a/Types/RepoSize.hs +++ b/Types/RepoSize.hs @@ -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. diff --git a/Types/TrustLevel.hs b/Types/TrustLevel.hs --- a/Types/TrustLevel.hs +++ b/Types/TrustLevel.hs @@ -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 diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -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 diff --git a/Utility/Aeson.hs b/Utility/Aeson.hs --- a/Utility/Aeson.hs +++ b/Utility/Aeson.hs @@ -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) diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -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 [] _ = [] diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -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. -} diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -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 diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -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 -} diff --git a/Utility/Tor.hs b/Utility/Tor.hs --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -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 $ diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20240831 +Version: 10.20240927 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -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