ec66d53 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

fix transaction merge test

ec66d53AgentM6 years ago

src/lib/ProjectM36/TransactionGraph.hs+17−10

compare with master

unifiedsplit

@@ -345,11 +345,12 @@ createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transact

345createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do

346 graph <- gfGraph

347 selectedTrans <- validateHeadName selectedBranch graph t2

348+ pure $ addMerkleHash graph $

348− pure $ Transaction newId (TransactionInfo {

349+ Transaction newId (TransactionInfo {

349− parents = NE.fromList [transactionId trans1,

350+ parents = NE.fromList [transactionId trans1,

350− transactionId trans2],

351+ transactionId trans2],

351− stamp = stamp',

352+ stamp = stamp',

352− merkleHash = unimplemented }) (schemas selectedTrans)

353+ merkleHash = mempty }) (schemas selectedTrans)

353

354

354-- merge functions, relvars, individually

355-- merge functions, relvars, individually

355createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

356createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

@@ -504,11 +505,12 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do

504 typeConstructorMapping = types

505 typeConstructorMapping = types

505 }

506 }

506 newSchemas = Schemas newContext (subschemas t1)

507 newSchemas = Schemas newContext (subschemas t1)

508+ pure $ addMerkleHash graph $

507− pure (Transaction newId (TransactionInfo {

509+ Transaction newId (TransactionInfo {

508− parents = NE.fromList [transactionId t1,

510+ parents = NE.fromList [transactionId t1,

509− transactionId t2],

511+ transactionId t2],

510− stamp = stamp',

512+ stamp = stamp',

511− merkleHash = unimplemented }) newSchemas)

513+ merkleHash = mempty }) newSchemas

512

514

513lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

515lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

514lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

516lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

@@ -584,6 +586,11 @@ autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) disc

584 pure (discon''''', graph''''')

586 pure (discon''''', graph''''')

585

587

586

588

589+addMerkleHash :: TransactionGraph -> Transaction -> Transaction

590+addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas trans)

591+ where

592+ newInfo = (transactionInfo trans) { merkleHash = calculateMerkleHash trans graph }

593+

587-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions

594-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions

588calculateMerkleHash :: Transaction -> TransactionGraph -> BS.ByteString

595calculateMerkleHash :: Transaction -> TransactionGraph -> BS.ByteString

589calculateMerkleHash trans graph = hashlazy (mconcat ([transIds,

596calculateMerkleHash trans graph = hashlazy (mconcat ([transIds,

test/TransactionGraph/Merge.hs+25−15

@@ -4,6 +4,7 @@ import ProjectM36.Base

4import ProjectM36.Attribute

5import ProjectM36.Relation

6import ProjectM36.Transaction

7+import ProjectM36.TransactionInfo as TI

7import ProjectM36.TransactionGraph

8import ProjectM36.TransactionGraph

8import ProjectM36.Error

9import ProjectM36.Error

9import ProjectM36.Key

10import ProjectM36.Key

@@ -14,6 +15,17 @@ import ProjectM36.StaticOptimizer

15import qualified Data.ByteString.Lazy as BS

16import qualified Data.ByteString.Lazy as BS

16import System.Exit

17import System.Exit

18+

19+

20+

21+

22+

23+

24+

25+

26+

27+

28+

17import Data.Word

29import Data.Word

18import qualified Data.UUID as U

30import qualified Data.UUID as U

19import qualified Data.Set as S

31import qualified Data.Set as S

@@ -21,7 +33,6 @@ import qualified Data.Map as M

21import Data.Maybe

33import Data.Maybe

22import Data.Time.Clock

34import Data.Time.Clock

23import Data.Time.Calendar

35import Data.Time.Calendar

24−import qualified Data.List.NonEmpty as NE

26{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

37{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

@@ -61,10 +72,9 @@ basicTransactionGraph = do

61 uuidA = fakeUUID 10

72 uuidA = fakeUUID 10

62 uuidB = fakeUUID 11

73 uuidB = fakeUUID 11

63 uuidRoot = fakeUUID 1

74 uuidRoot = fakeUUID 1

64− parents' = uuidRoot NE.:| []

65 rootContext = concreteDatabaseContext rootTrans

75 rootContext = concreteDatabaseContext rootTrans

66− (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo parents' testTime) rootContext) bsGraph

76+ (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TI.singleParent uuidRoot testTime) rootContext) bsGraph

67− (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo parents' testTime) rootContext) bsGraph'

77+ (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TI.singleParent uuidRoot testTime) rootContext) bsGraph'

68 pure bsGraph''

78 pure bsGraph''

70addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

80addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

@@ -108,7 +118,7 @@ testSubGraphToFirstAncestorSnipBranch = TestCase $ do

108 baseGraph <- basicTransactionGraph

118 baseGraph <- basicTransactionGraph

109 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

119 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

110 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

120 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

111− (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1 NE.:| []) testTime) (concreteDatabaseContext transA)) baseGraph

121+ (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TI.singleParent (fakeUUID 1) testTime) (concreteDatabaseContext transA)) baseGraph

112 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty

122 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty

113 assertGraph subgraph

123 assertGraph subgraph

114 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

124 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

@@ -127,13 +137,13 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

127 updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of

137 updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of

128 Left err -> assertFailure (show err) >> undefined

138 Left err -> assertFailure (show err) >> undefined

129 Right st -> pure $ dbc_context st

139 Right st -> pure $ dbc_context st

130− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph

140+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph

131 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"

141 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"

132 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')

142 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')

133

143

134 -- add another transaction to branchA

144 -- add another transaction to branchA

135 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"

145 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'

146+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) (concreteDatabaseContext branchATrans)) graph'

137 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"

147 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"

138 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')

148 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')

139

149

@@ -156,7 +166,7 @@ testSelectedBranchMerge = TestCase $ do

156 updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of

166 updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of

157 Left err -> assertFailure (show err) >> undefined

167 Left err -> assertFailure (show err) >> undefined

158 Right st -> pure (dbc_context st)

168 Right st -> pure (dbc_context st)

159− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph

169+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph

160 --create the merge transaction in the graph

170 --create the merge transaction in the graph

161 let eGraph' = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB")

171 let eGraph' = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB")

162 gfEnv = freshGraphRefRelationalExprEnv Nothing graph'

172 gfEnv = freshGraphRefRelationalExprEnv Nothing graph'

@@ -185,8 +195,8 @@ testUnionPreferMergeStrategy = TestCase $ do

185 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))}

195 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))}

186 conflictRelVarName = "conflictRelVar"

196 conflictRelVarName = "conflictRelVar"

187

197

188− (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph

198+ (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph

189− (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph'

199+ (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph'

190 -- validate that the conflict is hidden because we preferred a branch

200 -- validate that the conflict is hidden because we preferred a branch

191 let merged = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB")

201 let merged = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB")

192 env = freshGraphRefRelationalExprEnv Nothing graph''

202 env = freshGraphRefRelationalExprEnv Nothing graph''

@@ -215,7 +225,7 @@ testUnionMergeStrategy = TestCase $ do

215 branchAOnlyIncDepName = "branchAOnlyIncDep"

225 branchAOnlyIncDepName = "branchAOnlyIncDep"

216 branchBOnlyRelVarName = "branchBOnlyRelVar"

226 branchBOnlyRelVarName = "branchBOnlyRelVar"

217 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

227 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

218− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph

228+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph

219 let env = freshGraphRefRelationalExprEnv Nothing graph'

229 let env = freshGraphRefRelationalExprEnv Nothing graph'

220 (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB")

230 (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB")

221 let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))

231 let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))

@@ -223,7 +233,7 @@ testUnionMergeStrategy = TestCase $ do

223 reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph

233 reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph

224

234

225 assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel

235 assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel

226− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) updatedBranchAContext) graph'

236+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) updatedBranchAContext) graph'

227 let eMergeGraph = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

237 let eMergeGraph = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

228 gfEnv = freshGraphRefRelationalExprEnv Nothing graph''

238 gfEnv = freshGraphRefRelationalExprEnv Nothing graph''

229 case eMergeGraph of

239 case eMergeGraph of

@@ -243,7 +253,7 @@ testUnionMergeStrategy = TestCase $ do

243 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []

253 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []

244 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) }

254 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) }

245 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"

255 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"

246− (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans NE.:| []) testTime) conflictContextA) graph''

256+ (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TI.singleParent (transactionId conflictBranchATrans) testTime) conflictContextA) graph''

247 let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

257 let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

248 gfEnv' = freshGraphRefRelationalExprEnv Nothing graph'''

258 gfEnv' = freshGraphRefRelationalExprEnv Nothing graph'''

249 case failingMerge of

259 case failingMerge of

@@ -272,9 +282,9 @@ testUnionMergeIncDepViolation = TestCase $ do

272

282

273

283

274 --add the rv in new commits to both branches

284 --add the rv in new commits to both branches

275− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph

285+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph

276

286

277− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph'

287+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph'

278

288

279 --check that the union merge fails due to a violated constraint

289 --check that the union merge fails due to a violated constraint

280 let eMerge = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

290 let eMerge = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")