840 lines
27 KiB
Haskell
840 lines
27 KiB
Haskell
{- git-annex simulator
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Annex.Sim where
|
|
|
|
import Annex.Common
|
|
import Utility.DataUnits
|
|
import Types.NumCopies
|
|
import Types.Group
|
|
import Types.StandardGroups
|
|
import Types.TrustLevel
|
|
import Types.Difference
|
|
import Git
|
|
import Backend.Hash (genTestKey)
|
|
import Annex.UUID
|
|
import Annex.FileMatcher
|
|
import Annex.Init
|
|
import Annex.Startup
|
|
import Annex.Link
|
|
import Annex.Wanted
|
|
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 qualified Annex
|
|
import qualified Remote
|
|
import qualified Git.Construct
|
|
import qualified Annex.Queue
|
|
|
|
import System.Random
|
|
import Data.Word
|
|
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 = SimState
|
|
{ simRepos :: M.Map RepoName UUID
|
|
, simRepoList :: [RepoName]
|
|
, simRepoState :: M.Map RepoName SimRepoState
|
|
, simConnections :: M.Map UUID (S.Set RemoteName)
|
|
, simFiles :: M.Map RawFilePath Key
|
|
, simRng :: StdGen
|
|
, simTrustLevels :: M.Map UUID TrustLevel
|
|
, simNumCopies :: NumCopies
|
|
, simMinCopies :: MinCopies
|
|
, simGroups :: M.Map UUID (S.Set Group)
|
|
, simWanted :: M.Map UUID PreferredContentExpression
|
|
, simRequired :: M.Map UUID PreferredContentExpression
|
|
, simGroupWanted :: M.Map Group PreferredContentExpression
|
|
, simMaxSize :: M.Map UUID MaxSize
|
|
, simRebalance :: Bool
|
|
, simGetExistingRepoByName :: GetExistingRepoByName
|
|
, simGetSimRepoPath :: GetSimRepoPath
|
|
, simHistory :: [SimCommand]
|
|
, simVectorClock :: VectorClock
|
|
}
|
|
deriving (Show)
|
|
|
|
emptySimState :: StdGen -> GetExistingRepoByName -> GetSimRepoPath -> SimState
|
|
emptySimState rng repobyname getpath = SimState
|
|
{ simRepos = mempty
|
|
, simRepoList = mempty
|
|
, simRepoState = mempty
|
|
, simConnections = mempty
|
|
, simFiles = mempty
|
|
, simRng = rng
|
|
, simTrustLevels = mempty
|
|
, simNumCopies = configuredNumCopies 1
|
|
, simMinCopies = configuredMinCopies 1
|
|
, simGroups = mempty
|
|
, simWanted = mempty
|
|
, simRequired = mempty
|
|
, simGroupWanted = mempty
|
|
, simMaxSize = mempty
|
|
, simRebalance = False
|
|
, simGetExistingRepoByName = repobyname
|
|
, simGetSimRepoPath = getpath
|
|
, simHistory = []
|
|
, simVectorClock = VectorClock 0
|
|
}
|
|
|
|
-- State that can vary between different repos in the simulation.
|
|
data SimRepoState = SimRepoState
|
|
{ simLocations :: M.Map Key (M.Map UUID LocationState)
|
|
, simIsSpecialRemote :: Bool
|
|
, simRepo :: Maybe SimRepo
|
|
}
|
|
deriving (Show)
|
|
|
|
data LocationState = LocationState VectorClock Bool
|
|
deriving (Eq, Show)
|
|
|
|
newtype VectorClock = VectorClock Int
|
|
deriving (Eq, Ord, Show)
|
|
|
|
newerLocationState :: LocationState -> LocationState -> LocationState
|
|
newerLocationState l1@(LocationState vc1 _) l2@(LocationState vc2 _)
|
|
| vc1 > vc2 = l1
|
|
| otherwise = l2
|
|
|
|
setPresentKey :: UUID -> Key -> RepoName -> SimState -> SimState
|
|
setPresentKey u k repo st = st
|
|
{ simRepoState = case M.lookup repo (simRepoState st) of
|
|
Just rst -> M.insert repo
|
|
(setPresentKey' (simVectorClock st) u k rst)
|
|
(simRepoState st)
|
|
Nothing -> error "no simRepoState in setPresentKey"
|
|
}
|
|
|
|
setPresentKey' :: VectorClock -> UUID -> Key -> SimRepoState -> SimRepoState
|
|
setPresentKey' vc u k rst = rst
|
|
{ simLocations =
|
|
M.insertWith (M.unionWith newerLocationState) k
|
|
(M.singleton u (LocationState vc True))
|
|
(simLocations rst)
|
|
}
|
|
|
|
getSimLocations :: SimRepoState -> 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 -> SimCommand -> SimState
|
|
addHistory st c = st { simHistory = c : simHistory st }
|
|
|
|
newtype RepoName = RepoName { fromRepoName :: String }
|
|
deriving (Show, Eq, Ord)
|
|
|
|
newtype RemoteName = RemoteName { fromRemoteName :: String }
|
|
deriving (Show, Eq, Ord)
|
|
|
|
remoteNameToRepoName :: RemoteName -> RepoName
|
|
remoteNameToRepoName (RemoteName n) = RepoName n
|
|
|
|
data SimCommand
|
|
= CommandInit RepoName
|
|
| CommandInitRemote RepoName
|
|
| CommandUse RepoName String
|
|
| CommandConnect RepoName RemoteName
|
|
| CommandDisconnect RepoName RemoteName
|
|
| CommandAddTree RepoName PreferredContentExpression
|
|
| CommandAdd RawFilePath ByteSize [RepoName]
|
|
| CommandStep Int
|
|
| CommandAction RepoName SimAction
|
|
| CommandSeed Int
|
|
| CommandPresent RepoName RawFilePath
|
|
| CommandNotPresent RepoName RawFilePath
|
|
| CommandNumCopies Int
|
|
| CommandMinCopies Int
|
|
| CommandTrustLevel RepoName String
|
|
| CommandGroup RepoName Group
|
|
| CommandUngroup RepoName Group
|
|
| CommandWanted RepoName PreferredContentExpression
|
|
| CommandRequired RepoName PreferredContentExpression
|
|
| CommandGroupWanted Group PreferredContentExpression
|
|
| CommandMaxSize RepoName MaxSize
|
|
| CommandRebalance Bool
|
|
| CommandComment String
|
|
| CommandBlank
|
|
deriving (Show)
|
|
|
|
data SimAction
|
|
= ActionPull RemoteName
|
|
| ActionPush RemoteName
|
|
| ActionGetWanted RemoteName
|
|
| ActionDropUnwanted (Maybe RemoteName)
|
|
| ActionSendWanted RemoteName
|
|
| ActionGitPush RemoteName
|
|
| ActionGitPull RemoteName
|
|
deriving (Show)
|
|
|
|
runSimCommand :: SimCommand -> SimState -> Annex SimState
|
|
runSimCommand (CommandStep n) st
|
|
| n > 0 = case randomRepo st of
|
|
(Just (repo, u), st') ->
|
|
let (act, st'') = randomAction u st'
|
|
in runSimCommand (CommandAction repo act) st''
|
|
>>= runSimCommand (CommandStep (pred n))
|
|
(Nothing, st') -> return st'
|
|
| otherwise = return st
|
|
runSimCommand cmd st = case applySimCommand cmd st of
|
|
Left err -> giveup err
|
|
Right (Right st') -> return st'
|
|
Right (Left mkst) -> mkst
|
|
|
|
applySimCommand
|
|
:: SimCommand
|
|
-> SimState
|
|
-> Either String (Either (Annex SimState) SimState)
|
|
applySimCommand cmd st =
|
|
applySimCommand' cmd $ flip addHistory cmd $ st
|
|
{ simVectorClock =
|
|
let (VectorClock clk) = simVectorClock st
|
|
in VectorClock (succ clk)
|
|
}
|
|
|
|
applySimCommand'
|
|
:: SimCommand
|
|
-> SimState
|
|
-> Either String (Either (Annex SimState) SimState)
|
|
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 =
|
|
case getExistingRepoByName (simGetExistingRepoByName st) 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 repo remote) st =
|
|
checkKnownRepo repo st $ \u -> Right $ Right $ 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)
|
|
}
|
|
applySimCommand' (CommandDisconnect repo remote) st =
|
|
checkKnownRepo repo st $ \u -> Right $ Right $ 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)
|
|
}
|
|
applySimCommand' (CommandAddTree repo expr) st =
|
|
checkKnownRepo repo st $ const $
|
|
checkValidPreferredContentExpression expr $ Left $
|
|
error "TODO" -- XXX
|
|
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 u k repo $ st'
|
|
{ simFiles = M.insert file k (simFiles st')
|
|
}
|
|
in go k st'' rest
|
|
applySimCommand' (CommandStep _) _ = error "applySimCommand' CommandStep"
|
|
applySimCommand' (CommandAction repo act) st =
|
|
checkKnownRepo repo st $ \u ->
|
|
applySimAction repo u act st
|
|
applySimCommand' (CommandSeed rngseed) st = Right $ Right $ st
|
|
{ simRng = mkStdGen rngseed
|
|
}
|
|
applySimCommand' (CommandPresent repo file) st = checkKnownRepo repo st $ \u ->
|
|
case (M.lookup file (simFiles st), M.lookup repo (simRepoState st)) of
|
|
(Just k, Just rst)
|
|
| u `S.member` getSimLocations rst k ->
|
|
Right $ Right st
|
|
| otherwise -> missing
|
|
(Just _, Nothing) -> missing
|
|
(Nothing, _) -> Left $ "Expected " ++ fromRawFilePath file
|
|
++ " to be present in " ++ fromRepoName repo
|
|
++ ", but the simulation does not include that file."
|
|
where
|
|
missing = Left $ "Expected " ++ fromRawFilePath file
|
|
++ " to be present in "
|
|
++ fromRepoName repo ++ ", but it is not."
|
|
applySimCommand' (CommandNotPresent repo file) st = checkKnownRepo repo st $ \u ->
|
|
case (M.lookup file (simFiles st), M.lookup repo (simRepoState st)) of
|
|
(Just k, Just rst)
|
|
| u `S.notMember` getSimLocations rst k ->
|
|
Right $ Right st
|
|
| otherwise -> present
|
|
(Just _, Nothing) -> present
|
|
(Nothing, _) -> Left $ "Expected " ++ fromRawFilePath file
|
|
++ " to not be present in " ++ fromRepoName repo
|
|
++ ", but the simulation does not include that file."
|
|
where
|
|
present = Left $ "Expected " ++ fromRawFilePath file
|
|
++ " not to be present in "
|
|
++ fromRepoName repo ++ ", but it is present."
|
|
applySimCommand' (CommandNumCopies n) st = Right $ Right $ st
|
|
{ simNumCopies = configuredNumCopies n
|
|
}
|
|
applySimCommand' (CommandMinCopies n) st = Right $ Right $ st
|
|
{ simMinCopies = configuredMinCopies n
|
|
}
|
|
applySimCommand' (CommandTrustLevel repo s) st = checkKnownRepo repo st $ \u ->
|
|
case readTrustLevel s of
|
|
Just trustlevel -> Right $ Right $ st
|
|
{ simTrustLevels = M.insert u trustlevel
|
|
(simTrustLevels st)
|
|
}
|
|
Nothing -> Left $ "Unknown trust level \"" ++ s ++ "\"."
|
|
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' (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' (CommandMaxSize repo sz) st = checkKnownRepo repo st $ \u ->
|
|
Right $ Right $ st
|
|
{ simMaxSize = M.insert u sz (simMaxSize st)
|
|
}
|
|
applySimCommand' (CommandRebalance b) st = Right $ Right $ st
|
|
{ simRebalance = b
|
|
}
|
|
applySimCommand' (CommandComment _) st = Right $ Right st
|
|
applySimCommand' CommandBlank st = Right $ Right st
|
|
|
|
applySimAction
|
|
:: RepoName
|
|
-> UUID
|
|
-> SimAction
|
|
-> SimState
|
|
-> Either String (Either (Annex SimState) SimState)
|
|
applySimAction r u (ActionPull remote) st = undefined -- TODO
|
|
applySimAction r u (ActionPush remote) st = undefined -- TODO
|
|
applySimAction r u (ActionGetWanted remote) st =
|
|
overFilesRemote r u remote S.member wanted go st
|
|
where
|
|
wanted k f _ = wantGet NoLiveUpdate False k f
|
|
go u _ f k r st' = setPresentKey u k r $
|
|
addHistory st' $ CommandPresent r f
|
|
applySimAction r u (ActionSendWanted remote) st =
|
|
overFilesRemote r u remote S.notMember wanted go st
|
|
where
|
|
wanted = wantGetBy NoLiveUpdate False
|
|
go _ remoteu f k r st' = setPresentKey remoteu k r $
|
|
-- Sending to a remote updates the location log
|
|
-- of both the repository sending and the remote.
|
|
setPresentKey remoteu k (remoteNameToRepoName remote) $
|
|
addHistory st' $ CommandPresent (remoteNameToRepoName remote) f
|
|
applySimAction r u (ActionDropUnwanted Nothing) st = undefined -- TODO
|
|
applySimAction r u (ActionDropUnwanted (Just remote)) st = undefined -- TODO
|
|
applySimAction r u (ActionGitPush remote) st =
|
|
checkKnownRemote remote r u st $ \_ ->
|
|
simulateGitAnnexMerge r (remoteNameToRepoName remote) st
|
|
applySimAction r u (ActionGitPull remote) st =
|
|
checkKnownRemote remote r u st $ \_ ->
|
|
simulateGitAnnexMerge (remoteNameToRepoName remote) r st
|
|
|
|
overFilesRemote
|
|
:: RepoName
|
|
-> UUID
|
|
-> RemoteName
|
|
-> (UUID -> S.Set UUID -> Bool)
|
|
-> (Maybe Key -> AssociatedFile -> UUID -> Annex Bool)
|
|
-> (UUID -> UUID -> RawFilePath -> Key -> RepoName -> SimState -> SimState)
|
|
-> SimState
|
|
-> Either String (Either (Annex SimState) SimState)
|
|
overFilesRemote r u remote remotepred checkwant handlewanted st =
|
|
checkKnownRemote remote r u st $ \remoteu ->
|
|
Right $ Left $ liftIO $
|
|
runSimRepo r st $ \rst ->
|
|
let l = M.toList $
|
|
M.filter (checkremotepred remoteu rst) $
|
|
simFiles st
|
|
in go remoteu l st
|
|
where
|
|
go _ [] st' = return st'
|
|
go remoteu ((f, k):rest) st' = do
|
|
ifM (checkwant (Just k) af remoteu)
|
|
( go remoteu rest $ handlewanted u remoteu f k r st'
|
|
, go remoteu rest st'
|
|
)
|
|
where
|
|
af = AssociatedFile $ Just f
|
|
|
|
checkremotepred remoteu rst k =
|
|
remotepred remoteu (getSimLocations rst k)
|
|
|
|
simulateGitAnnexMerge
|
|
:: RepoName
|
|
-> RepoName
|
|
-> SimState
|
|
-> Either String (Either (Annex SimState) SimState)
|
|
simulateGitAnnexMerge src dest st =
|
|
case M.lookup dest (simRepoState st) of
|
|
Nothing -> Left $ "Unable to find simRepoState for " ++ fromRepoName dest
|
|
Just destst -> case M.lookup src (simRepoState st) of
|
|
Nothing -> Left $ "Unable to find simRepoState for " ++ fromRepoName src
|
|
Just srcst -> Right $ Right $
|
|
let locs = M.unionWith
|
|
(M.unionWith newerLocationState)
|
|
(simLocations destst)
|
|
(simLocations srcst)
|
|
destst' = destst { simLocations = locs }
|
|
in st
|
|
{ simRepoState = M.insert dest
|
|
destst'
|
|
(simRepoState st)
|
|
}
|
|
|
|
checkNonexistantRepo :: RepoName -> SimState -> Either String a -> Either String a
|
|
checkNonexistantRepo reponame st a = case M.lookup reponame (simRepos st) of
|
|
Nothing -> a
|
|
Just _ -> Left $ "There is already a repository in the simulation named \""
|
|
++ fromRepoName reponame ++ "\"."
|
|
|
|
checkKnownRepo :: RepoName -> SimState -> (UUID -> Either String a) -> Either String a
|
|
checkKnownRepo reponame st a = case M.lookup reponame (simRepos st) of
|
|
Just u -> a u
|
|
Nothing -> Left $ "No repository in the simulation is named \""
|
|
++ fromRepoName reponame ++ "\"."
|
|
|
|
checkKnownRemote :: RemoteName -> RepoName -> UUID -> SimState -> (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 expr v =
|
|
case checkPreferredContentExpression expr of
|
|
Nothing -> Right v
|
|
Just e -> Left $ "Failed parsing \"" ++ expr ++ "\": " ++ e
|
|
|
|
simRandom :: SimState -> (StdGen -> (v, StdGen)) -> (v -> r) -> (r, SimState)
|
|
simRandom st mk f =
|
|
let (v, rng) = mk (simRng st)
|
|
in (f v, st { simRng = rng })
|
|
|
|
randomRepo :: SimState -> (Maybe (RepoName, UUID), SimState)
|
|
randomRepo st
|
|
| null (simRepoList st) = (Nothing, st)
|
|
| otherwise = simRandom st
|
|
(randomR (0, length (simRepoList st) - 1)) $ \n -> do
|
|
let r = simRepoList st !! n
|
|
u <- M.lookup r (simRepos st)
|
|
return (r, u)
|
|
|
|
randomAction :: UUID -> SimState -> (SimAction, SimState)
|
|
randomAction u st = case M.lookup u (simConnections st) of
|
|
Just cs | not (S.null cs) ->
|
|
let (mkact, st') = simRandom st (randomR (0, length mkactions - 1))
|
|
(mkactions !!)
|
|
(remote, st'') = simRandom st' (randomR (0, S.size cs - 1))
|
|
(`S.elemAt` cs)
|
|
in (mkact remote, st'')
|
|
-- When there are no remotes, this is the only possible action.
|
|
_ -> (ActionDropUnwanted Nothing, st)
|
|
where
|
|
mkactions =
|
|
[ ActionPull
|
|
, ActionPush
|
|
, ActionGetWanted
|
|
, ActionDropUnwanted . Just
|
|
, const (ActionDropUnwanted Nothing)
|
|
, ActionSendWanted
|
|
, ActionGitPush
|
|
, ActionGitPull
|
|
]
|
|
|
|
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 -> (Key, SimState)
|
|
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 -> RepoName -> (UUID, SimState)
|
|
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"
|
|
|
|
newtype GetSimRepoPath = GetSimRepoPath (UUID -> FilePath)
|
|
|
|
instance Show GetSimRepoPath where
|
|
show _ = "GetSimRepoPath"
|
|
|
|
data SimRepoConfig = SimRepoConfig
|
|
{ simRepoUUID :: UUID
|
|
, simRepoIsSpecialRemote :: Bool
|
|
, simRepoGroups :: S.Set Group
|
|
, simRepoTrustLevel :: TrustLevel
|
|
, simRepoPreferredContent :: Maybe PreferredContentExpression
|
|
, simRepoRequiredContent :: Maybe PreferredContentExpression
|
|
, simRepoGroupPreferredContent :: M.Map Group PreferredContentExpression
|
|
, simRepoMaxSize :: Maybe MaxSize
|
|
}
|
|
deriving (Show)
|
|
|
|
newSimRepoConfig :: UUID -> Bool -> SimRepoConfig
|
|
newSimRepoConfig u isspecialremote = SimRepoConfig
|
|
{ simRepoUUID = u
|
|
, simRepoIsSpecialRemote = isspecialremote
|
|
, simRepoGroups = mempty
|
|
, simRepoTrustLevel = def
|
|
, simRepoPreferredContent = Nothing
|
|
, simRepoRequiredContent = Nothing
|
|
, simRepoGroupPreferredContent = mempty
|
|
, simRepoMaxSize = Nothing
|
|
}
|
|
|
|
addRepo :: RepoName -> SimRepoConfig -> SimState -> SimState
|
|
addRepo reponame simrepo st = st
|
|
{ simRepos = M.insert reponame u (simRepos st)
|
|
, simRepoList = if reponame `elem` simRepoList st
|
|
then simRepoList st
|
|
else reponame : simRepoList st
|
|
, simRepoState = M.insert reponame rst (simRepoState st)
|
|
, simConnections = M.insert u mempty (simConnections st)
|
|
, simGroups = M.insert u (simRepoGroups simrepo) (simGroups st)
|
|
, simTrustLevels = M.insert u
|
|
(simRepoTrustLevel simrepo)
|
|
(simTrustLevels st)
|
|
, simWanted = M.alter
|
|
(const $ simRepoPreferredContent simrepo)
|
|
u
|
|
(simWanted st)
|
|
, simRequired = M.alter
|
|
(const $ simRepoRequiredContent simrepo)
|
|
u
|
|
(simRequired st)
|
|
, simGroupWanted = M.union
|
|
(simRepoGroupPreferredContent simrepo)
|
|
(simGroupWanted st)
|
|
, simMaxSize = M.alter
|
|
(const $ simRepoMaxSize simrepo)
|
|
u
|
|
(simMaxSize st)
|
|
}
|
|
where
|
|
u = simRepoUUID simrepo
|
|
rst = SimRepoState
|
|
{ simLocations = mempty
|
|
, simIsSpecialRemote = simRepoIsSpecialRemote simrepo
|
|
, simRepo = Nothing
|
|
}
|
|
|
|
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
|
|
{ simRepoUUID = u
|
|
, simRepoIsSpecialRemote =
|
|
M.member u remoteconfigmap
|
|
, simRepoGroups = gs
|
|
, simRepoTrustLevel =
|
|
lookupTrust' u trustmap
|
|
, simRepoPreferredContent =
|
|
M.lookup u pcmap
|
|
, simRepoRequiredContent =
|
|
M.lookup u rcmap
|
|
, simRepoGroupPreferredContent =
|
|
M.restrictKeys gpcmap gs
|
|
, simRepoMaxSize =
|
|
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
|
|
, simRepoName :: RepoName
|
|
}
|
|
|
|
instance Show SimRepo where
|
|
show _ = "SimRepo"
|
|
|
|
{- Inits and updates SimRepos to reflect the SimState. -}
|
|
updateSimRepos :: SimState -> IO SimState
|
|
updateSimRepos st = updateSimRepoStates st >>= initNewSimRepos
|
|
|
|
updateSimRepoStates :: SimState -> IO SimState
|
|
updateSimRepoStates st = go st (M.toList $ simRepoState st)
|
|
where
|
|
go st' [] = return st'
|
|
go st' ((reponame, rst):rest) = case simRepo rst of
|
|
Just sr -> do
|
|
sr' <- updateSimRepoState st sr
|
|
let rst' = rst { simRepo = Just sr' }
|
|
let st'' = st
|
|
{ simRepoState = M.insert reponame rst'
|
|
(simRepoState st)
|
|
}
|
|
go st'' rest
|
|
Nothing -> go st' rest
|
|
|
|
initNewSimRepos :: SimState -> IO SimState
|
|
initNewSimRepos = \st -> go st (M.toList $ simRepoState st)
|
|
where
|
|
go st [] = return st
|
|
go st ((reponame, rst):rest) =
|
|
case (simRepo rst, M.lookup reponame (simRepos st)) of
|
|
(Nothing, Just u) -> do
|
|
let GetSimRepoPath getdest = simGetSimRepoPath st
|
|
sr <- initSimRepo reponame u (getdest u) st
|
|
let rst' = rst { simRepo = Just sr }
|
|
let st' = st
|
|
{ simRepoState = M.insert reponame rst'
|
|
(simRepoState st)
|
|
}
|
|
go st' rest
|
|
_ -> go st rest
|
|
|
|
initSimRepo :: RepoName -> UUID -> FilePath -> SimState -> 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)
|
|
(simGetExistingRepoByName st)
|
|
(simGetSimRepoPath st)
|
|
, simRepoName = simreponame
|
|
}
|
|
|
|
simulatedRepositoryDescription :: RepoName -> String
|
|
simulatedRepositoryDescription simreponame =
|
|
"simulated repository " ++ fromRepoName simreponame
|
|
|
|
simulationDifferences :: Differences
|
|
simulationDifferences = mkDifferences $ S.singleton Simulation
|
|
|
|
runSimRepo :: RepoName -> SimState -> (SimRepoState -> Annex SimState) -> IO SimState
|
|
runSimRepo reponame st a = do
|
|
st' <- updateSimRepos st
|
|
case M.lookup reponame (simRepoState st') of
|
|
Just rst -> case simRepo rst of
|
|
Just sr -> do
|
|
(st'', strd) <- Annex.run (simRepoAnnex sr) $
|
|
doQuietAction (a rst)
|
|
let sr' = sr
|
|
{ simRepoAnnex = strd
|
|
}
|
|
return $ st''
|
|
{ simRepoState = M.adjust
|
|
(\rst' -> rst' { simRepo = Just sr' })
|
|
(simRepoName sr)
|
|
(simRepoState st'')
|
|
}
|
|
Nothing -> error $ "runSimRepo simRepo not set for " ++ fromRepoName reponame
|
|
Nothing -> error $ "runSimRepo simRepoState not found for " ++ fromRepoName reponame
|
|
|
|
updateSimRepoState :: SimState -> 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 simWanted $ DiffUpdate
|
|
{ replaceDiff = const . preferredContentSet
|
|
, addDiff = preferredContentSet
|
|
, removeDiff = const . flip preferredContentSet mempty
|
|
}
|
|
updateField oldst newst simRequired $ DiffUpdate
|
|
{ replaceDiff = const . requiredContentSet
|
|
, addDiff = requiredContentSet
|
|
, removeDiff = const . flip requiredContentSet mempty
|
|
}
|
|
updateField oldst newst simGroupWanted $ DiffUpdate
|
|
{ replaceDiff = const . groupPreferredContentSet
|
|
, addDiff = groupPreferredContentSet
|
|
, removeDiff = const . flip groupPreferredContentSet mempty
|
|
}
|
|
updateField oldst newst simMaxSize $ DiffUpdate
|
|
{ replaceDiff = const . 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 = const . 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
|
|
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 (simRepoName 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 ()
|
|
}
|
|
|
|
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)
|