git.iko.soy/project-m36
on cfa7253 help sign in
project-m36/test/TransactionGraph/Merge.hs
265 lines 16 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
14import qualified Data.ByteString.Lazy as BS
15import System.Exit
16import Data.Word
17import qualified Data.UUID as U
18import qualified Data.Set as S
19import qualified Data.Map as M
20import Data.Maybe
21import Data.Time.Clock
22import Data.Time.Calendar
24import Control.Monad.State
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 rootContext = concreteDatabaseContext rootTrans
65 (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph
66 (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph'
67 pure bsGraph''
69addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)
70addTransaction headName transaction graph = case addTransactionToGraph headName transaction graph of
71 Left err -> assertFailure (show err) >> error ""
72 Right (t,g) -> pure (t,g)
74fakeUUID :: Word8 -> TransactionId
75fakeUUID x = fromMaybe (error "impossible uuid") (U.fromByteString (BS.concat (replicate 4 w32)))
76 where w32 = BS.pack (replicate 4 x)
78assertEither :: (Show a) => Either a b -> IO b
79assertEither x = case x of
80 Left err -> assertFailure (show err) >> undefined
81 Right val -> pure val
83assertGraph :: TransactionGraph -> IO ()
84assertGraph graph = case validateGraph graph of
85 Nothing -> pure ()
86 Just errs -> assertFailure (show errs)
88assertMaybe :: Maybe a -> String -> IO a
89assertMaybe x msg = case x of
90 Nothing -> assertFailure msg >> undefined
91 Just x' -> pure x'
93-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).
94testSubGraphToFirstAncestorBasic :: Test
95testSubGraphToFirstAncestorBasic = TestCase $ do
96 graph <- basicTransactionGraph
97 assertGraph graph
98 transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"
99 transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"
100 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty
101 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
102 assertEqual "no graph changes" (graphEq subgraph) (graphEq graph)
104-- | Test that a branch anchored at the root transaction is removed when using the first ancestor function.
105testSubGraphToFirstAncestorSnipBranch :: Test
106testSubGraphToFirstAncestorSnipBranch = TestCase $ do
107 baseGraph <- basicTransactionGraph
108 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"
109 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"
110 (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty testTime) (concreteDatabaseContext transA)) baseGraph
111 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty
112 assertGraph subgraph
113 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
114 assertEqual "failed to snip branch" (graphEq baseGraph) (graphEq subgraph)
116-- | Test that the subgraph function recurses properly through multiple parent transactions.
117testSubGraphToFirstAncestorMoreTransactions :: Test
118testSubGraphToFirstAncestorMoreTransactions = TestCase $ do
119 graph <- basicTransactionGraph
120 assertGraph graph
122-- add another relvar to branchB
123 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
124 (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of
125 (Left err, _) -> assertFailure (show err) >> undefined
126 (Right (), context) -> pure context
127 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph
128 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"
129 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')
131 -- add another transaction to branchA
132 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
133 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) (concreteDatabaseContext branchATrans)) graph'
134 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"
135 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')
137 --retrieve subgraph
138 let subGraphHeads = M.filter (\t -> transactionId t `elem` [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'')
139 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph'' subGraphHeads branchATrans' branchBTrans' S.empty
140 --verify that the subgraph includes both the heads and the common ancestor
141 let expectedTransSet = S.fromList (map fakeUUID [1,3,4])
142 assertBool "validate transactions in subgraph" (S.isProperSubsetOf expectedTransSet (S.map transactionId (transactionsForGraph subgraph)))
144testSelectedBranchMerge :: Test
145testSelectedBranchMerge = TestCase $ do
146 graph <- basicTransactionGraph
147 assertGraph graph
149 -- add another relvar to branchB
150 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
151 (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of
152 (Left err, _) -> assertFailure (show err) >> undefined
153 (Right (), context) -> pure context
154 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph
155 --create the merge transaction in the graph
156 let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'
158 (_, graph'') <- assertEither eGraph'
160 assertGraph graph''
161 --validate that the branchB remains
162 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph'') "failed to find branchB head"
163 assertEqual "head of merged transaction was removed" (transactionId branchBTrans') (fakeUUID 3)
165 --validate that the branchB relvar does *not* appear in the merge because branchA was selected
166 mergeTrans <- assertEither (transactionForId (fakeUUID 4) graph'')
167 assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (concreteDatabaseContext mergeTrans)))
169-- try various individual component conflicts and check for resolution
170testUnionPreferMergeStrategy :: Test
171testUnionPreferMergeStrategy = TestCase $ do
172 -- create a graph with a relvar conflict
173 graph <- basicTransactionGraph
174 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "branchATrans"
175 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans"
176 branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
177 let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))}
178 branchARelVar = relationTrue
179 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}
180 conflictRelVarName = "conflictRelVar"
182 (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph
183 (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph'
184 -- validate that the conflict is hidden because we preferred a branch
185 let merged = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''
186 case merged of
187 Left err -> assertFailure ("expected merge success: " ++ show err)
188 Right (discon, _) ->
189 assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))
191-- try various individual component conflicts and check for merge failure
192testUnionMergeStrategy :: Test
193testUnionMergeStrategy = TestCase $ do
194 graph <- basicTransactionGraph
195 assertGraph graph
197 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
198 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
199 -- add another relvar to branchB - branchBOnlyRelvar should appear in the merge
200 -- add inclusion dependency in branchA
202 let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) }
203 updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) }
204 branchBOnlyRelVar = relationTrue
205 branchAOnlyIncDepName = "branchAOnlyIncDep"
206 branchBOnlyRelVarName = "branchBOnlyRelVar"
207 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)
208 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph
209 (discon, _) <- assertEither $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'
210 assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)
211 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) updatedBranchAContext) graph'
212 let eMergeGraph = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''
213 case eMergeGraph of
214 Left err -> assertFailure ("expected merge success: " ++ show err)
215 Right (_, mergeGraph) -> do
216 -- check that the new merge transaction has the correct parents
217 mergeTrans <- assertEither $ transactionForId (fakeUUID 5) mergeGraph
218 let mergeContext = concreteDatabaseContext mergeTrans
219 assertEqual "merge transaction parents" (transactionParentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])
220 -- check that the new merge tranasction has elements from both A and B branches
221 assertEqual "merge transaction relvars" (Just relationTrue) (M.lookup branchBOnlyRelVarName (relationVariables mergeContext))
222 assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext))
223 -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes
224 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
225 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }
226 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"
227 (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty testTime) conflictContextA) graph''
228 let failingMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''
229 case failingMerge of
230 Right _ -> assertFailure "expected merge failure"
231 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)
233-- test that a merge will fail if a constraint is violated
234testUnionMergeIncDepViolation :: Test
235testUnionMergeIncDepViolation = TestCase $ do
236 graph <- basicTransactionGraph
237 assertGraph graph
239 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
240 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
242 --add relvar and key constraint to both branches
243 let eRel val = mkRelationFromList (attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 1, IntAtom val]]
244 rvName = "x"
245 Right branchArv = eRel 2
246 Right branchBrv = eRel 3
247 branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchArv}
248 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchBrv,
249 inclusionDependencies = M.singleton incDepName incDep}
250 incDepName = "x_key"
251 incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())
254 --add the rv in new commits to both branches
255 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph
257 (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph'
259 --check that the union merge fails due to a violated constraint
260 let eMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''
261 case eMerge of
262 Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName'
263 Left err -> assertFailure ("other error: " ++ show err)
264 Right _ -> assertFailure "constraint violation missing"