git.iko.soy/project-m36
on 56f748d help sign in
project-m36/test/TransactionGraph/Merge.hs
296 lines 17 kB history raw
1-- tests for transaction merging
2import Test.HUnit
3import ProjectM36.Base
4import ProjectM36.Attribute
5import ProjectM36.Relation
6import ProjectM36.Transaction
7import ProjectM36.TransactionInfo as TI
8import ProjectM36.TransactionGraph
9import ProjectM36.Error
10import ProjectM36.Key
11import qualified ProjectM36.DisconnectedTransaction as Discon
12import qualified ProjectM36.DatabaseContext as DBC
13import ProjectM36.RelationalExpression
14import ProjectM36.StaticOptimizer
16import qualified Data.ByteString.Lazy as BS
17import System.Exit
29import Data.Word
30import qualified Data.UUID as U
31import qualified Data.Set as S
32import qualified Data.Map as M
33import Data.Maybe
34import Data.Time.Clock
35import Data.Time.Calendar
37{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
39testTime :: UTCTime
40testTime = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)
42main :: IO ()
43main = do
44 tcounts <- runTestTT testList
45 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
47testList :: Test
48testList = TestList [
49 testSubGraphToFirstAncestorBasic,
50 testSubGraphToFirstAncestorSnipBranch,
51 testSubGraphToFirstAncestorMoreTransactions,
52 testSelectedBranchMerge,
53 testUnionMergeStrategy,
54 testUnionPreferMergeStrategy,
55 testUnionMergeIncDepViolation
56 ]
58-- | Create a transaction graph with two branches and no changes between them.
59{-
60root 1
61|--- branchA aaaa
62|--- branchB bbbb
63-}
65createTrans :: TransactionId -> TransactionInfo -> DatabaseContext -> Transaction
66createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty)
68basicTransactionGraph :: IO TransactionGraph
69basicTransactionGraph = do
70 let bsGraph = bootstrapTransactionGraph testTime uuidRoot DBC.basicDatabaseContext
71 rootTrans = fromMaybe (error "bonk") (transactionForHead "master" bsGraph)
72 uuidA = fakeUUID 10
73 uuidB = fakeUUID 11
74 uuidRoot = fakeUUID 1
75 rootContext = concreteDatabaseContext rootTrans
76 (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TI.singleParent uuidRoot testTime) rootContext) bsGraph
77 (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TI.singleParent uuidRoot testTime) rootContext) bsGraph'
78 pure bsGraph''
80addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)
81addTransaction headName transaction graph = case addTransactionToGraph headName transaction graph of
82 Left err -> assertFailure (show err) >> error ""
83 Right (t,g) -> pure (t,g)
85fakeUUID :: Word8 -> TransactionId
86fakeUUID x = fromMaybe (error "impossible uuid") (U.fromByteString (BS.concat (replicate 4 w32)))
87 where w32 = BS.pack (replicate 4 x)
89assertEither :: (Show a) => Either a b -> IO b
90assertEither x = case x of
91 Left err -> assertFailure (show err) >> undefined
92 Right val -> pure val
94assertGraph :: TransactionGraph -> IO ()
95assertGraph graph = case validateGraph graph of
96 Nothing -> pure ()
97 Just errs -> assertFailure (show errs)
99assertMaybe :: Maybe a -> String -> IO a
100assertMaybe x msg = case x of
101 Nothing -> assertFailure msg >> undefined
102 Just x' -> pure x'
104-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).
105testSubGraphToFirstAncestorBasic :: Test
106testSubGraphToFirstAncestorBasic = TestCase $ do
107 graph <- basicTransactionGraph
108 assertGraph graph
109 transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"
110 transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"
111 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty
112 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
113 assertEqual "no graph changes" (graphEq subgraph) (graphEq graph)
115-- | Test that a branch anchored at the root transaction is removed when using the first ancestor function.
116testSubGraphToFirstAncestorSnipBranch :: Test
117testSubGraphToFirstAncestorSnipBranch = TestCase $ do
118 baseGraph <- basicTransactionGraph
119 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"
120 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"
121 (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TI.singleParent (fakeUUID 1) testTime) (concreteDatabaseContext transA)) baseGraph
122 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty
123 assertGraph subgraph
124 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
125 assertEqual "failed to snip branch" (graphEq baseGraph) (graphEq subgraph)
127-- | Test that the subgraph function recurses properly through multiple parent transactions.
128testSubGraphToFirstAncestorMoreTransactions :: Test
129testSubGraphToFirstAncestorMoreTransactions = TestCase $ do
130 graph <- basicTransactionGraph
131 assertGraph graph
133-- add another relvar to branchB
134 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
135 let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph
136 branchBContext = concreteDatabaseContext branchBTrans
137 updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of
138 Left err -> assertFailure (show err) >> undefined
139 Right st -> pure $ dbc_context st
140 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph
141 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"
142 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')
144 -- add another transaction to branchA
145 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
146 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) (concreteDatabaseContext branchATrans)) graph'
147 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"
148 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')
150 --retrieve subgraph
151 let subGraphHeads = M.filter (\t -> transactionId t `elem` [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'')
152 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph'' subGraphHeads branchATrans' branchBTrans' S.empty
153 --verify that the subgraph includes both the heads and the common ancestor
154 let expectedTransSet = S.fromList (map fakeUUID [1,3,4])
155 assertBool "validate transactions in subgraph" (S.isProperSubsetOf expectedTransSet (S.map transactionId (transactionsForGraph subgraph)))
157testSelectedBranchMerge :: Test
158testSelectedBranchMerge = TestCase $ do
159 graph <- basicTransactionGraph
160 assertGraph graph
162 -- add another relvar to branchB
163 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
164 let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph
165 branchBContext = concreteDatabaseContext branchBTrans
166 updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of
167 Left err -> assertFailure (show err) >> undefined
168 Right st -> pure (dbc_context st)
169 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph
170 --create the merge transaction in the graph
171 let eGraph' = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB")
172 gfEnv = freshGraphRefRelationalExprEnv Nothing graph'
174 (_, graph'') <- assertEither eGraph'
176 assertGraph graph''
177 --validate that the branchB remains
178 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph'') "failed to find branchB head"
179 assertEqual "head of merged transaction was removed" (transactionId branchBTrans') (fakeUUID 3)
181 --validate that the branchB relvar does *not* appear in the merge because branchA was selected
182 mergeTrans <- assertEither (transactionForId (fakeUUID 4) graph'')
183 assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (concreteDatabaseContext mergeTrans)))
185-- try various individual component conflicts and check for resolution
186testUnionPreferMergeStrategy :: Test
187testUnionPreferMergeStrategy = TestCase $ do
188 -- create a graph with a relvar conflict
189 graph <- basicTransactionGraph
190 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "branchATrans"
191 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans"
192 branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
193 let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))}
194 branchARelVar = ExistingRelation relationTrue
195 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))}
196 conflictRelVarName = "conflictRelVar"
198 (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph
199 (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph'
200 -- validate that the conflict is hidden because we preferred a branch
201 let merged = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB")
202 env = freshGraphRefRelationalExprEnv Nothing graph''
203 case merged of
204 Left err -> assertFailure ("expected merge success: " ++ show err)
205 Right (discon, _) -> do
206 let Just rvExpr = M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon))
207 reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph
208 let eRvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)
209 assertEqual "branchB relvar preferred in conflict" (Right branchBRelVar) eRvRel
211-- try various individual component conflicts and check for merge failure
212testUnionMergeStrategy :: Test
213testUnionMergeStrategy = TestCase $ do
214 graph <- basicTransactionGraph
215 assertGraph graph
217 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
218 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
219 -- add another relvar to branchB - branchBOnlyRelvar should appear in the merge
220 -- add inclusion dependency in branchA
222 let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) }
223 updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) }
224 branchBOnlyRelVar = ExistingRelation relationTrue
225 branchAOnlyIncDepName = "branchAOnlyIncDep"
226 branchBOnlyRelVarName = "branchBOnlyRelVar"
227 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)
228 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph
229 let env = freshGraphRefRelationalExprEnv Nothing graph'
230 (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB")
231 let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))
232 Right rvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)
233 reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph
235 assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel
236 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) updatedBranchAContext) graph'
237 let eMergeGraph = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")
238 gfEnv = freshGraphRefRelationalExprEnv Nothing graph''
239 case eMergeGraph of
240 Left err -> assertFailure ("expected merge success: " ++ show err)
241 Right (_, mergeGraph) -> do
242 -- check that the new merge transaction has the correct parents
243 mergeTrans <- assertEither $ transactionForId (fakeUUID 5) mergeGraph
244 let mergeContext = concreteDatabaseContext mergeTrans
245 assertEqual "merge transaction parents" (parentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])
246 -- check that the new merge tranasction has elements from both A and B branches
247 let Just rvExpr' = M.lookup branchBOnlyRelVarName (relationVariables mergeContext)
248 Right rvRel' = runGraphRefRelationalExprM reEnv' (evalGraphRefRelationalExpr rvExpr')
249 reEnv' = freshGraphRefRelationalExprEnv (Just mergeContext) graph
250 assertEqual "merge transaction relvars" relationTrue rvRel'
251 assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext))
252 -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes
253 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
254 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) }
255 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"
256 (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TI.singleParent (transactionId conflictBranchATrans) testTime) conflictContextA) graph''
257 let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")
258 gfEnv' = freshGraphRefRelationalExprEnv Nothing graph'''
259 case failingMerge of
260 Right _ -> assertFailure "expected merge failure"
261 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)
263-- test that a merge will fail if a constraint is violated
264testUnionMergeIncDepViolation :: Test
265testUnionMergeIncDepViolation = TestCase $ do
266 graph <- basicTransactionGraph
267 assertGraph graph
269 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
270 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
272 --add relvar and key constraint to both branches
273 let eRel val = mkRelationFromList (attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 1, IntAtom val]]
274 rvName = "x"
275 Right branchArv = eRel 2
276 Right branchBrv = eRel 3
277 branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchArv)}
278 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchBrv),
279 inclusionDependencies = M.singleton incDepName incDep}
280 incDepName = "x_key"
281 incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())
284 --add the rv in new commits to both branches
285 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph
287 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph'
289 --check that the union merge fails due to a violated constraint
290 let eMerge = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")
291 env = freshGraphRefRelationalExprEnv Nothing graph''
292 case eMerge of
293 Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName'
294 Left err -> assertFailure ("other error: " ++ show err)
295 Right _ -> assertFailure "constraint violation missing"