git.iko.soy/project-m36
on 62_python_dbapi help sign in
project-m36/test/TransactionGraph/Merge.hs
223 lines 13 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 qualified Data.ByteString.Lazy as BS
10import System.Exit
11import Data.Word
12import ProjectM36.RelationalExpression
13import qualified ProjectM36.DisconnectedTransaction as Discon
14import qualified Data.UUID as U
15import qualified Data.Set as S
16import qualified Data.Map as M
17import qualified ProjectM36.DatabaseContext as DBC
18import Control.Monad.State hiding (join)
20main :: IO ()
21main = do
22 tcounts <- runTestTT testList
23 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
25testList :: Test
26testList = TestList [
27 testSubGraphToFirstAncestorBasic,
28 testSubGraphToFirstAncestorSnipBranch,
29 testSubGraphToFirstAncestorMoreTransactions,
30 testSelectedBranchMerge,
31 testUnionMergeStrategy,
32 testUnionPreferMergeStrategy
33 ]
35-- | Create a transaction graph with two branches and no changes between them.
36{-
37root 1
38|--- branchA aaaa
39|--- branchB bbbb
40-}
42createTrans :: TransactionId -> TransactionInfo -> DatabaseContext -> Transaction
43createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty)
45basicTransactionGraph :: IO TransactionGraph
46basicTransactionGraph = do
47 let bsGraph = bootstrapTransactionGraph uuidRoot DBC.empty --dateExamples
48 rootTrans = case transactionForHead "master" bsGraph of
49 Just trans -> trans
50 Nothing -> error "bonk"
51 uuidA = fakeUUID 10
52 uuidB = fakeUUID 11
53 uuidRoot = fakeUUID 1
54 rootContext = concreteDatabaseContext rootTrans
55 (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty) rootContext) bsGraph
56 (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty) rootContext) bsGraph'
57 pure bsGraph''
59addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)
60addTransaction headName transaction graph = case addTransactionToGraph headName transaction graph of
61 Left err -> assertFailure (show err) >> error ""
62 Right (t,g) -> pure (t,g)
64fakeUUID :: Word8 -> TransactionId
65fakeUUID x = case U.fromByteString (BS.concat (replicate 4 w32)) of
66 Nothing -> error "impossible uuid"
67 Just u -> u
68 where w32 = BS.pack (replicate 4 x)
70assertEither :: (Show a) => Either a b -> IO b
71assertEither x = case x of
72 Left err -> assertFailure (show err) >> undefined
73 Right val -> pure val
75assertGraph :: TransactionGraph -> IO ()
76assertGraph graph = case validateGraph graph of
77 Nothing -> pure ()
78 Just errs -> assertFailure (show errs)
80assertMaybe :: Maybe a -> String -> IO a
81assertMaybe x msg = case x of
82 Nothing -> assertFailure msg >> undefined
83 Just x' -> pure x'
85-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).
86testSubGraphToFirstAncestorBasic :: Test
87testSubGraphToFirstAncestorBasic = TestCase $ do
88 graph <- basicTransactionGraph
89 assertGraph graph
90 transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"
91 transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"
92 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty
93 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
94 assertEqual "no graph changes" (graphEq subgraph) (graphEq graph)
96-- | Test that a branch anchored at the root transaction is removed when using the first ancestor function.
97testSubGraphToFirstAncestorSnipBranch :: Test
98testSubGraphToFirstAncestorSnipBranch = TestCase $ do
99 baseGraph <- basicTransactionGraph
100 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"
101 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"
102 (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty) (concreteDatabaseContext transA)) baseGraph
103 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty
104 assertGraph subgraph
105 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
106 assertEqual "failed to snip branch" (graphEq baseGraph) (graphEq subgraph)
108-- | Test that the subgraph function recurses properly through multiple parent transactions.
109testSubGraphToFirstAncestorMoreTransactions :: Test
110testSubGraphToFirstAncestorMoreTransactions = TestCase $ do
111 graph <- basicTransactionGraph
112 assertGraph graph
114 -- add another relvar to branchB
115 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
116 updatedBranchBContext <- case runState (evalContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (concreteDatabaseContext branchBTrans) of
117 (Just err, _) -> assertFailure (show err) >> undefined
118 (Nothing, context) -> pure context
119 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph
120 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"
121 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')
123 -- add another transaction to branchA
124 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
125 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) (concreteDatabaseContext branchATrans)) graph'
126 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"
127 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')
129 --retrieve subgraph
130 let subGraphHeads = M.filter (\t -> elem (transactionId t) [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'')
131 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph'' subGraphHeads branchATrans' branchBTrans' S.empty
132 --verify that the subgraph includes both the heads and the common ancestor
133 let expectedTransSet = S.fromList (map fakeUUID [1,3,4])
134 assertBool "validate transactions in subgraph" (S.isProperSubsetOf expectedTransSet (S.map transactionId (transactionsForGraph subgraph)))
136testSelectedBranchMerge :: Test
137testSelectedBranchMerge = TestCase $ do
138 graph <- basicTransactionGraph
139 assertGraph graph
141 -- add another relvar to branchB
142 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
143 updatedBranchBContext <- case runState (evalContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (concreteDatabaseContext branchBTrans) of
144 (Just err, _) -> assertFailure (show err) >> undefined
145 (Nothing, context) -> pure context
146 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph
147 --create the merge transaction in the graph
148 let eGraph' = mergeTransactions (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'
150 (_, graph'') <- assertEither eGraph'
152 assertGraph graph''
153 --validate that the branchB remains
154 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph'') "failed to find branchB head"
155 assertEqual "head of merged transaction was removed" (transactionId branchBTrans') (fakeUUID 3)
157 --validate that the branchB relvar does *not* appear in the merge because branchA was selected
158 mergeTrans <- assertEither (transactionForId (fakeUUID 4) graph'')
159 assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (concreteDatabaseContext mergeTrans)))
161-- try various individual component conflicts and check for resolution
162testUnionPreferMergeStrategy :: Test
163testUnionPreferMergeStrategy = TestCase $ do
164 -- create a graph with a relvar conflict
165 graph <- basicTransactionGraph
166 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "branchATrans"
167 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans"
168 branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
169 let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))}
170 branchARelVar = relationTrue
171 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}
172 conflictRelVarName = "conflictRelVar"
174 (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty) branchAContext) graph
175 (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty) branchBContext) graph'
176 -- validate that the conflict is hidden because we preferred a branch
177 let merged = mergeTransactions (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''
178 case merged of
179 Left err -> assertFailure ("expected merge success: " ++ show err)
180 Right (discon, _) -> do
181 assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))
183-- try various individual component conflicts and check for merge failure
184testUnionMergeStrategy :: Test
185testUnionMergeStrategy = TestCase $ do
186 graph <- basicTransactionGraph
187 assertGraph graph
189 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
190 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
191 -- add another relvar to branchB - branchBOnlyRelvar should appear in the merge
192 -- add inclusion dependency in branchA
194 let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) }
195 updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) }
196 branchBOnlyRelVar = relationTrue
197 branchAOnlyIncDepName = "branchAOnlyIncDep"
198 branchBOnlyRelVarName = "branchBOnlyRelVar"
199 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)
200 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph
201 (discon, _) <- assertEither $ mergeTransactions (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'
202 assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)
203 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) updatedBranchAContext) graph'
204 let eMergeGraph = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''
205 case eMergeGraph of
206 Left err -> assertFailure ("expected merge success: " ++ show err)
207 Right (_, mergeGraph) -> do
208 -- check that the new merge transaction has the correct parents
209 mergeTrans <- assertEither $ transactionForId (fakeUUID 5) mergeGraph
210 let mergeContext = concreteDatabaseContext mergeTrans
211 assertEqual "merge transaction parents" (transactionParentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])
212 -- check that the new merge tranasction has elements from both A and B branches
213 assertEqual "merge transaction relvars" (Just relationTrue) (M.lookup branchBOnlyRelVarName (relationVariables mergeContext))
214 assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext))
215 -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes
216 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
217 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }
218 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"
219 (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty) conflictContextA) graph''
220 let failingMerge = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''
221 case failingMerge of
222 Right _ -> assertFailure "expected merge failure"
223 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)