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