ec66d53 · project-m36 · git.iko.soy

git.iko.soy/project-m36

fix transaction merge test

commitec66d53723c2377dfe27e50b3185a064b872950b authorAgentM <agentm@themactionfaction.com> dateThu 28 May 2020, 00:51 (6 years ago) parent469c243

2 files changed+42−25

compare with master

unifiedsplit

src/lib/ProjectM36/TransactionGraph.hs+17−10 test/TransactionGraph/Merge.hs+25−15

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

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

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

346346 graph <- gfGraph

347347 selectedTrans <- validateHeadName selectedBranch graph t2

348− pure $ Transaction newId (TransactionInfo {

349− parents = NE.fromList [transactionId trans1,

350− transactionId trans2],

351− stamp = stamp',

352− merkleHash = unimplemented }) (schemas selectedTrans)

348+ pure $ addMerkleHash graph $

349+ Transaction newId (TransactionInfo {

350+ parents = NE.fromList [transactionId trans1,

351+ transactionId trans2],

352+ stamp = stamp',

353+ merkleHash = mempty }) (schemas selectedTrans)

353354

354355-- merge functions, relvars, individually

355356createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

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

504505 typeConstructorMapping = types

505506 }

506507 newSchemas = Schemas newContext (subschemas t1)

507− pure (Transaction newId (TransactionInfo {

508− parents = NE.fromList [transactionId t1,

509− transactionId t2],

510− stamp = stamp',

511− merkleHash = unimplemented }) newSchemas)

508+ pure $ addMerkleHash graph $

509+ Transaction newId (TransactionInfo {

510+ parents = NE.fromList [transactionId t1,

511+ transactionId t2],

512+ stamp = stamp',

513+ merkleHash = mempty }) newSchemas

512514

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

514516lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

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

584586 pure (discon''''', graph''''')

585587

586588

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+

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

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

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

test/TransactionGraph/Merge.hs+25−15

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

44import ProjectM36.Attribute

55import ProjectM36.Relation

66import ProjectM36.Transaction

7+import ProjectM36.TransactionInfo as TI

78import ProjectM36.TransactionGraph

89import ProjectM36.Error

910import ProjectM36.Key

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

1415

1516import qualified Data.ByteString.Lazy as BS

1617import System.Exit

18+

19+

20+

21+

22+

23+

24+

25+

26+

27+

28+

1729import Data.Word

1830import qualified Data.UUID as U

1931import qualified Data.Set as S

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

2133import Data.Maybe

2234import Data.Time.Clock

2335import Data.Time.Calendar

24−import qualified Data.List.NonEmpty as NE

2536

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

2738

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

6172 uuidA = fakeUUID 10

6273 uuidB = fakeUUID 11

6374 uuidRoot = fakeUUID 1

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

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

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

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

6878 pure bsGraph''

6979

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

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

108118 baseGraph <- basicTransactionGraph

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

110120 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

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

113123 assertGraph subgraph

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

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

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

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

129139 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

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

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

133143

134144 -- add another transaction to branchA

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

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

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

139149

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

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

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

158168 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

160170 --create the merge transaction in the graph

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

162172 gfEnv = freshGraphRefRelationalExprEnv Nothing graph'

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

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

186196 conflictRelVarName = "conflictRelVar"

187197

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

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

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

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

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

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

192202 env = freshGraphRefRelationalExprEnv Nothing graph''

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

215225 branchAOnlyIncDepName = "branchAOnlyIncDep"

216226 branchBOnlyRelVarName = "branchBOnlyRelVar"

217227 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

219229 let env = freshGraphRefRelationalExprEnv Nothing graph'

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

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

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

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

224234

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

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

228238 gfEnv = freshGraphRefRelationalExprEnv Nothing graph''

229239 case eMergeGraph of

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

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

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

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

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

248258 gfEnv' = freshGraphRefRelationalExprEnv Nothing graph'''

249259 case failingMerge of

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

272282

273283

274284 --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

276286

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'

278288

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

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