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