sim: implement ActionGitPush and ActionGitPull

These don't actually need to do any git actions, instead they just merge
the simLocations.

Had to make simLocations use a vector clock, because it is possible for
two simulated repositories to end up with different opinions about the
location of a key. Just like with real git-annex, whichever location
change was made most recently wins out.

The vector clock is simply advanced each time the simulation is run for
a step. Since there is no real parallelism in the sim, that's
sufficient.

diff --git a/Annex/Sim.hs b/Annex/Sim.hs
index 98bc6585281d813f4d284c007a6dfa6ce11db515..f0be23a6cde76229e2095cbb08cd5fc976e588f0 100644 (file)
--- a/Annex/Sim.hs
+++ b/Annex/Sim.hs
@@ -67,6 +67,7 @@ data SimState = SimState
        , simRebalance :: Bool
        , simGetExistingRepoByName :: GetExistingRepoByName
        , simHistory :: [SimCommand]
+       , simVectorClock :: VectorClock
        }
        deriving (Show)
 
@@ -89,11 +90,12 @@ emptySimState rng repobyname = SimState
        , simRebalance = False
        , simGetExistingRepoByName = repobyname
        , simHistory = []
+       , simVectorClock = VectorClock 0
        }
 
 -- State that can vary between different repos in the simulation.
 data SimRepoState = SimRepoState
-       { simLocations :: M.Map Key (S.Set UUID)
+       { simLocations :: M.Map Key (M.Map UUID LocationState)
        , simIsSpecialRemote :: Bool
        , simRepo :: Maybe SimRepo
        }
@@ -101,18 +103,44 @@ data SimRepoState = SimRepoState
 instance Show SimRepoState where
        show _ = "SimRepoState"
 
-setPresentKey :: UUID -> Key -> SimRepoState -> SimRepoState
-setPresentKey u k rst = rst
+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 :: VectorClock -> UUID -> Key -> SimRepoState -> SimRepoState
+setPresentKey vc u k rst = rst
        { simLocations = 
-               M.insertWith S.union k (S.singleton u) (simLocations rst)
+               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
+
 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
@@ -149,6 +177,14 @@ data SimAction
        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'
@@ -158,16 +194,13 @@ applySimCommand
        :: SimCommand
        -> SimState
        -> Either String (Either (Annex SimState) SimState)
-applySimCommand (CommandStep n) st
-       | n > 0 = case randomRepo st of
-               (Just (_repo, u), st') ->
-                       let (act, st'') = randomAction u st'
-                           st''' = applySimAction u act st''
-                       in applySimCommand (CommandStep (pred n)) st'''
-               (Nothing, st') -> Right $ Right st'
-       | otherwise = Right $ Right st
 applySimCommand c st = 
-       applySimCommand' c $ st { simHistory = c : simHistory st }
+       applySimCommand' c $ st
+               { simHistory = c : simHistory st
+               , simVectorClock = 
+                       let (VectorClock c) = simVectorClock st 
+                       in VectorClock (succ c)
+               }
 
 applySimCommand'
        :: SimCommand
@@ -214,22 +247,23 @@ applySimCommand' (CommandAdd file sz repo) st = checkKnownRepo repo st $ \u ->
                { simFiles = M.insert (toRawFilePath file) k (simFiles st')
                , simRepoState = case M.lookup repo (simRepoState st') of
                        Just rst -> M.insert repo
-                               (setPresentKey u k rst)
+                               (setPresentKey (simVectorClock st) u k rst)
                                (simRepoState st')
                        Nothing -> error "no simRepoState in applySimCommand CommandAdd"
                }
 applySimCommand' (CommandStep _) _ = error "applySimCommand' CommandStep"
 applySimCommand' (CommandAction repo act) st =
        checkKnownRepo repo st $ \u -> 
-               Right $ Right $ applySimAction u act st
+               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 (toRawFilePath file) (simFiles st), M.lookup repo (simRepoState st)) of
-               (Just k, Just rst) -> case M.lookup k (simLocations rst) of
-                       Just locs | S.member u locs -> Right $ Right st
-                       _ -> missing
+               (Just k, Just rst)
+                       | u `S.member` getSimLocations rst k ->
+                               Right $ Right st
+                       | otherwise -> missing
                (Just _, Nothing) -> missing
                (Nothing, _) -> Left $ "Expected " ++ file
                        ++ " to be present in " ++ fromRepoName repo 
@@ -239,9 +273,10 @@ applySimCommand' (CommandPresent repo file) st = checkKnownRepo repo st $ \u ->
                ++ fromRepoName repo ++ ", but it is not."
 applySimCommand' (CommandNotPresent repo file) st = checkKnownRepo repo st $ \u ->
        case (M.lookup (toRawFilePath file) (simFiles st), M.lookup repo (simRepoState st)) of
-               (Just k, Just rst) -> case M.lookup k (simLocations rst) of
-                       Just locs | S.notMember u locs -> Right $ Right st
-                       _ -> present
+               (Just k, Just rst)
+                       | u `S.notMember` getSimLocations rst k ->
+                               Right $ Right st
+                       | otherwise -> present
                (Just _, Nothing) -> present
                (Nothing, _) -> Left $ "Expected " ++ file
                        ++ " to not be present in " ++ fromRepoName repo 
@@ -293,15 +328,46 @@ applySimCommand' (CommandRebalance b) st = Right $ Right $ st
        }
 
 -- XXX todo
-applySimAction :: UUID -> SimAction -> SimState -> SimState
-applySimAction u (ActionPull remote) st = undefined
-applySimAction u (ActionPush remote) st = undefined
-applySimAction u (ActionGetWanted remote) st = undefined
-applySimAction u (ActionDropUnwanted Nothing) st = undefined
-applySimAction u (ActionDropUnwanted (Just remote)) st = undefined
-applySimAction u (ActionSendWanted remote) st = undefined
-applySimAction u (ActionGitPush remote) st = undefined
-applySimAction u (ActionGitPull remote) st = undefined
+applySimAction
+       :: RepoName
+       -> UUID
+       -> SimAction
+       -> SimState 
+       -> Either String (Either (Annex SimState) SimState)
+applySimAction r u (ActionPull remote) st = undefined
+applySimAction r u (ActionPush remote) st = undefined
+applySimAction r u (ActionGetWanted remote) st = undefined
+applySimAction r u (ActionDropUnwanted Nothing) st = undefined
+applySimAction r u (ActionDropUnwanted (Just remote)) st = undefined
+applySimAction r u (ActionSendWanted remote) st = undefined
+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
+
+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
@@ -315,6 +381,15 @@ checkKnownRepo reponame st a = case M.lookup reponame (simRepos st) of
        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 named \"" 
+                       ++ fromRemoteName remotename ++ "\"."
+
 checkValidPreferredContentExpression :: PreferredContentExpression -> v -> Either String v
 checkValidPreferredContentExpression expr v =
        case checkPreferredContentExpression expr of
@@ -499,7 +574,7 @@ updateSimRepos parent getdest st = do
 updateSimRepoStates :: SimState -> IO SimState
 updateSimRepoStates st = go st (M.toList $ simRepoState st)
   where
-       go st' [] = return st
+       go st' [] = return st'
        go st' ((reponame, rst):rest) = case simRepo rst of
                Just sr -> do
                        sr' <- updateSimRepoState st sr
@@ -619,12 +694,16 @@ updateSimRepoState newst sr = do
                        }
                updateField oldst newst getlocations $ DiffUpdate
                        { replaceDiff = \k oldls newls -> do
+                               let olds = getSimLocations' oldls
+                               let news = getSimLocations' newls
                                setlocations InfoPresent k
-                                       (S.difference newls oldls)
+                                       (S.difference news olds)
                                setlocations InfoMissing k
-                                       (S.difference oldls newls)
-                       , addDiff = setlocations InfoPresent
-                       , removeDiff = setlocations InfoMissing
+                                       (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
@@ -651,8 +730,7 @@ updateSimRepoState newst sr = do
        getlocations = maybe mempty simLocations
                . M.lookup (simRepoName sr)
                . simRepoState
-       setlocations s k ls = 
-               mapM_ (\l -> logChange NoLiveUpdate k l s) (S.toList ls)
+       setlocations s k = mapM_ (\l -> logChange NoLiveUpdate k l s)
 
 data DiffUpdate a b m = DiffUpdate
        { replaceDiff :: a -> b -> b -> m ()