git.iko.soy/project-m36
on master help sign in
auto merge tests pass

flip args on createSessionAtHead for consistency add constraint checking to post-merge operation- critical bug fixed

commit89229c7ec1452653cf096131fe5ab94da23208e8 authorAgentM <agentm@themactionfaction.com> dateMon 31 Jul 2017, 23:05 (9 years ago) parent248eb04
8 files changed+110−28
compare with master
unifiedsplit
project-m36.cabal+10 src/bin/TutorialD/tutd.hs+1−1 src/lib/ProjectM36/Client.hs+6−4 src/lib/ProjectM36/Server.hs+1−1 src/lib/ProjectM36/Server/EntryPoints.hs+3−3 src/lib/ProjectM36/TransactionGraph.hs+31−13 test/TransactionGraph/Automerge.hs+57−5 test/TutorialD/Interpreter/TestBase.hs+1−1
project-m36.cabal+10
@@ -480,4 +480,14 @@ Test-Suite test-multiprocess-access
480480 GHC-Options: -Wall
481481 Hs-Source-Dirs: ./src/bin, ., test/
482482 CPP-Options: -DPROJECTM36_VERSION="v0.1"
483+
484+Test-Suite test-automerge
485+ Default-Language: Haskell2010
486+ type: exitcode-stdio-1.0
487+ main-is: test/TransactionGraph/Automerge.hs
488+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom
489+ Default-Extensions: OverloadedStrings
490+ GHC-Options: -Wall
491+ Hs-Source-Dirs: ./src/bin, ., test/
492+ CPP-Options: -DPROJECTM36_VERSION="v0.1"
483493
src/bin/TutorialD/tutd.hs+1−1
@@ -91,7 +91,7 @@ main = do
9191 errDie ("Failed to create database connection: " ++ show err)
9292 Right conn -> do
9393 let connHeadName = headNameForConfig interpreterConfig
94− eSessionId <- createSessionAtHead connHeadName conn
94+ eSessionId <- createSessionAtHead conn connHeadName
9595 case eSessionId of
9696 Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
9797 Right sessionId -> do
src/lib/ProjectM36/Client.hs+6−4
@@ -45,6 +45,7 @@ module ProjectM36.Client
4545 DatabaseContextExpr(..),
4646 DatabaseContextIOExpr(..),
4747 Attribute(..),
48+ MergeStrategy(..),
4849 attributesFromList,
4950 createNodeId,
5051 createSessionAtCommit,
@@ -392,8 +393,8 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do
392393createSessionAtCommit_ _ _ (RemoteProcessConnection _) = error "createSessionAtCommit_ called on remote connection"
393394
394395-- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph.
395−createSessionAtHead :: HeadName -> Connection -> IO (Either RelationalError SessionId)
396−createSessionAtHead headn conn@(InProcessConnection conf) = do
396+createSessionAtHead :: Connection -> HeadName -> IO (Either RelationalError SessionId)
397+createSessionAtHead conn@(InProcessConnection conf) headn = do
397398 let graphTvar = ipTransactionGraph conf
398399 newSessionId <- nextRandom
399400 atomically $ do
@@ -401,7 +402,7 @@ createSessionAtHead headn conn@(InProcessConnection conf) = do
401402 case transactionForHead headn graph of
402403 Nothing -> pure $ Left (NoSuchHeadNameError headn)
403404 Just trans -> createSessionAtCommit_ (transactionId trans) newSessionId conn
404−createSessionAtHead headn conn@(RemoteProcessConnection _) = remoteCall conn (CreateSessionAtHead headn)
405+createSessionAtHead conn@(RemoteProcessConnection _) headn = remoteCall conn (CreateSessionAtHead headn)
405406
406407-- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.
407408addClientNode :: Connection -> ProcessId -> IO ()
@@ -571,12 +572,13 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do
571572 let sessions = ipSessions conf
572573 id1 <- nextRandom
573574 id2 <- nextRandom
575+ id3 <- nextRandom
574576 commitLock_ sessionId conf $ \graph -> do
575577 eSession <- sessionForSessionId sessionId sessions
576578 case eSession of
577579 Left err -> pure (Left err)
578580 Right session -> do
579− case Graph.autoMergeToHead (id1, id2) (Sess.disconnectedTransaction session) headName' strat graph of
581+ case Graph.autoMergeToHead (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of
580582 Left err -> pure (Left err)
581583 Right (discon', graph') -> pure (Right (discon', graph', True))
582584autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')
src/lib/ProjectM36/Server.hs+1−1
@@ -33,7 +33,7 @@ serverDefinition testBool ti = defaultProcess {
3333 handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),
3434 handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),
3535 handleCall (\conn (Login procId) -> handleLogin ti conn procId),
36− handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti headn conn),
36+ handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),
3737 handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti commitId conn),
3838 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),
3939 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),
src/lib/ProjectM36/Server/EntryPoints.hs+3−3
@@ -97,9 +97,9 @@ handleCreateSessionAtCommit ti commitId conn = do
9797 ret <- timeoutOrDie ti (createSessionAtCommit commitId conn)
9898 reply ret conn
9999
100−handleCreateSessionAtHead :: Timeout -> HeadName -> Connection -> Reply (Either RelationalError SessionId)
101−handleCreateSessionAtHead ti headn conn = do
102− ret <- timeoutOrDie ti (createSessionAtHead headn conn)
100+handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)
101+handleCreateSessionAtHead ti conn headn = do
102+ ret <- timeoutOrDie ti (createSessionAtHead conn headn)
103103 reply ret conn
104104
105105handleCloseSession :: Timeout -> SessionId -> Connection -> Reply ()
src/lib/ProjectM36/TransactionGraph.hs+31−13
@@ -19,6 +19,11 @@ import ProjectM36.TransactionGraph.Merge
1919import Data.Either (lefts, rights, isRight)
2020import Data.Monoid
2121
22+import Debug.Trace
23+import Control.Monad.Reader
24+import ProjectM36.RelationalExpression
25+import qualified ProjectM36.DisconnectedTransaction as D
26+
2227-- | Record a lookup for a specific transaction in the graph.
2328data TransactionIdLookup = TransactionIdLookup TransactionId |
2429 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
@@ -381,13 +386,15 @@ mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do
381386 subGraph' <- filterSubGraph subGraph subHeads
382387 case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of
383388 Left err -> Left (MergeTransactionError err)
384− Right mergedTrans -> case headNameForTransaction disconParent graph of
385− Nothing -> Left (TransactionIsNotAHeadError parentId)
386− Just headName -> do
387− (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
388− let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
389− newDiscon = DisconnectedTransaction newId (schemas newTrans) False
390− pure (newDiscon, newGraph')
389+ Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of
390+ Just err -> Left err
391+ Nothing -> case headNameForTransaction disconParent graph of
392+ Nothing -> Left (TransactionIsNotAHeadError parentId)
393+ Just headName -> do
394+ (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
395+ let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
396+ newDiscon = DisconnectedTransaction newId (schemas newTrans) False
397+ pure (newDiscon, newGraph')
391398
392399--TEMPORARY COPY/PASTE
393400showTransactionStructureX :: Transaction -> TransactionGraph -> String
@@ -480,13 +487,24 @@ backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
480487
481488-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.
482489--this is not a GraphOp because it combines multiple graph operations
483−autoMergeToHead :: (TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
484−autoMergeToHead (tempTransId, newCommitTransId) discon mergeToHeadName strat graph = do
485− let tempBranchName = "mergebranch_" <> U.toText tempTransId
490+autoMergeToHead :: (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
491+autoMergeToHead (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do
492+ let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId
486493 --create the temp branch
487− (discon', graph') <- evalGraphOp tempTransId discon graph (Branch tempBranchName)
494+ (discon', graph') <- evalGraphOp tempBranchTransId discon graph (Branch tempBranchName)
495+
496+ --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type
497+ (discon'', graph'') <- evalGraphOp tempCommitTransId discon' graph' Commit
498+
488499 --create the merge
489− (discon'', graph'') <- evalGraphOp newCommitTransId discon' graph' (MergeTransactions strat tempBranchName mergeToHeadName)
500+ (discon''', graph''') <- evalGraphOp mergeTransId discon'' graph'' (MergeTransactions strat tempBranchName mergeToHeadName)
501+
490502 --delete the temp branch
491− evalGraphOp newCommitTransId discon'' graph'' (DeleteBranch tempBranchName)
503+ (discon'''', graph'''') <- evalGraphOp tempBranchTransId discon''' graph''' (DeleteBranch tempBranchName)
504+
505+ let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
506+ traceShowM rel
507+ pure (discon'''', graph'''')
508+
509+
492510
test/TransactionGraph/Automerge.hs+57−5
@@ -1,10 +1,15 @@
11import Test.HUnit
22import ProjectM36.Client
3+import ProjectM36.Relation
4+import ProjectM36.Error
5+import qualified Data.Set as S
36import TutorialD.Interpreter.TestBase
4−import Data.UUID.V4 (nextRandom)
57
68import System.Exit
79
10+import ProjectM36.Relation.Show.Term
11+import Data.Text
12+
813main :: IO ()
914main = do
1015 tcounts <- runTestTT testList
@@ -13,12 +18,59 @@ main = do
1318testList :: Test
1419testList = TestList [testAutomergeSuccess,
1520 testAutomergeFailure]
21+
22+checkEither :: IO (Either RelationalError a) -> IO a
23+checkEither io = do
24+ ret <- io
25+ case ret of
26+ Left err -> assertFailure (show err)
27+ Right a -> pure a
1628
1729testAutomergeSuccess :: Test
30+testAutomergeSuccess = TestCase $ do
31+ --create two sessions, diverge from the head, and automerge back
32+ (sessionId, conn) <- dateExamplesConnection emptyNotificationCallback
33+ let headn = "master"
34+ sessionPastId <- checkEither $ createSessionAtHead conn headn
35+ executeTutorialD sessionId conn "insert s relation{tuple{city \"New City\", s# \"S6\", sname \"Samuels\", status 50}}"
36+ checkEither $ commit sessionId conn
37+
38+ executeTutorialD sessionPastId conn "insert s relation{tuple{city \"Merge City\", s# \"S7\", sname \"Mr. Merge\", status 60}}"
39+
40+ checkEither $ autoMergeToHead sessionPastId conn UnionMergeStrategy headn
41+
42+ --validate that both tuples are now in the head transaction
43+
44+ let predi key = eqAttr key
45+ eqAttr key = AttributeEqualityPredicate "s#" (NakedAtomExpr (TextAtom key))
46+ result <- checkEither $ executeRelationalExpr sessionPastId conn (Project (AttributeNames S.empty) (Restrict (predi "S6") (RelationVariable "s" ())))
47+ assertEqual "new S6" relationTrue result
48+
49+ result' <- checkEither $ executeRelationalExpr sessionPastId conn (Project (AttributeNames S.empty) (Restrict (predi "S7") (RelationVariable "s" ())))
50+
51+ assertEqual "new S7" relationTrue result'
52+
53+testAutomergeFailure :: Test
1854testAutomergeFailure = TestCase $ do
19− (sessionId, conn) <- dateExamplesConnection
20− sessionPastId <- createSessionAtHead "master"
21− executeTutorialD sessionId conn "insert s relation{tuple{city \"New City\", s# "S6", sname "Samuels", status 50}}"
22− commit sessionId conn
55+ --create two sessions, diverge from the head, but create a union merge strategy failure
56+ (sessionId, conn) <- dateExamplesConnection emptyNotificationCallback
57+ let headn = "master"
58+ sessionPastId <- checkEither $ createSessionAtHead conn headn
59+ executeTutorialD sessionId conn "insert s relation{tuple{city \"New City\", s# \"S6\", sname \"Samuels\", status 50}}"
60+ checkEither $ commit sessionId conn
61+
62+ --reuse the same id, violating the uniqueness constraint
63+ executeTutorialD sessionPastId conn "insert s relation{tuple{city \"Merge City\", s# \"S6\", sname \"Mr. Merge\", status 60}}"
64+
65+ --validate that both tuples are now in the head transaction
66+ --should fail
67+ mergeRes <- autoMergeToHead sessionPastId conn UnionMergeStrategy headn
68+
69+ p <- checkEither $ executeRelationalExpr sessionPastId conn (RelationVariable "s" ())
70+
71+ putStrLn (unpack (showRelation p))
72+
73+ assertEqual "merge failure" (Left (InclusionDependencyCheckError "s_pkey")) mergeRes
74+
2375
2476
test/TutorialD/Interpreter/TestBase.hs+1−1
@@ -16,7 +16,7 @@ dateExamplesConnection callback = do
1616 case dbconn of
1717 Left err -> error (show err)
1818 Right conn -> do
19− eSessionId <- createSessionAtHead "master" conn
19+ eSessionId <- createSessionAtHead conn "master"
2020 case eSessionId of
2121 Left err -> error (show err)
2222 Right sessionId -> do