git.iko.soy/project-m36
on master help sign in
all tests pass
commitadd8d97933583c4ddf475289fff373a9624b954a authorAgentM <agentm@themactionfaction.com> dateTue 1 Aug 2017, 10:35 (9 years ago) parent89229c7
9 files changed+64−29
compare with master
unifiedsplit
src/bin/ProjectM36/Server/WebSocket.hs+1−1 src/lib/ProjectM36/Client.hs+3−3 src/lib/ProjectM36/Server.hs+1−1 src/lib/ProjectM36/Server/EntryPoints.hs+3−3 src/lib/ProjectM36/TransactionGraph.hs+5−2 test/MultiProcessDatabaseAccess.hs+2−9 test/Server/Main.hs+3−3 test/TransactionGraph/Merge.hs+44−5 test/TransactionGraph/Persist.hs+2−2
src/bin/ProjectM36/Server/WebSocket.hs+1−1
@@ -32,7 +32,7 @@ websocketProxyServer port host pending = do
3232 case eDBconn of
3333 Left err -> sendError conn err
3434 Right dbconn -> do
35− eSessionId <- createSessionAtHead "master" dbconn
35+ eSessionId <- createSessionAtHead dbconn "master"
3636 case eSessionId of
3737 Left err -> sendError conn err
3838 Right sessionId -> do
src/lib/ProjectM36/Client.hs+3−3
@@ -368,12 +368,12 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc
368368 pure (Right conn)
369369
370370-- | Create a new session at the transaction id and return the session's Id.
371−createSessionAtCommit :: TransactionId -> Connection -> IO (Either RelationalError SessionId)
372−createSessionAtCommit commitId conn@(InProcessConnection _) = do
371+createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId)
372+createSessionAtCommit conn@(InProcessConnection _) commitId = do
373373 newSessionId <- nextRandom
374374 atomically $ do
375375 createSessionAtCommit_ commitId newSessionId conn
376−createSessionAtCommit uuid conn@(RemoteProcessConnection _) = remoteCall conn (CreateSessionAtCommit uuid)
376+createSessionAtCommit conn@(RemoteProcessConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid)
377377
378378createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)
379379createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do
src/lib/ProjectM36/Server.hs+1−1
@@ -34,7 +34,7 @@ serverDefinition testBool ti = defaultProcess {
3434 handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),
3535 handleCall (\conn (Login procId) -> handleLogin ti conn procId),
3636 handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),
37− handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti commitId conn),
37+ handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),
3838 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),
3939 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),
4040 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),
src/lib/ProjectM36/Server/EntryPoints.hs+3−3
@@ -92,9 +92,9 @@ handleRetrieveHeadTransactionId ti sessionId conn = do
9292 ret <- timeoutOrDie ti (headTransactionId sessionId conn)
9393 reply ret conn
9494
95−handleCreateSessionAtCommit :: Timeout -> TransactionId -> Connection -> Reply (Either RelationalError SessionId)
96−handleCreateSessionAtCommit ti commitId conn = do
97− ret <- timeoutOrDie ti (createSessionAtCommit commitId conn)
95+handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId)
96+handleCreateSessionAtCommit ti conn commitId = do
97+ ret <- timeoutOrDie ti (createSessionAtCommit conn commitId)
9898 reply ret conn
9999
100100handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)
src/lib/ProjectM36/TransactionGraph.hs+5−2
@@ -6,6 +6,7 @@ import ProjectM36.Transaction
66import ProjectM36.Relation
77import ProjectM36.TupleSet
88import ProjectM36.Tuple
9+import ProjectM36.RelationalExpression
910import qualified Data.Vector as V
1011import qualified ProjectM36.Attribute as A
1112import qualified Data.UUID as U
@@ -19,10 +20,11 @@ import ProjectM36.TransactionGraph.Merge
1920import Data.Either (lefts, rights, isRight)
2021import Data.Monoid
2122
23+{-
2224import Debug.Trace
2325import Control.Monad.Reader
24−import ProjectM36.RelationalExpression
2526import qualified ProjectM36.DisconnectedTransaction as D
27+-}
2628
2729-- | Record a lookup for a specific transaction in the graph.
2830data TransactionIdLookup = TransactionIdLookup TransactionId |
@@ -501,9 +503,10 @@ autoMergeToHead (tempBranchTransId, tempCommitTransId, mergeTransId) discon merg
501503
502504 --delete the temp branch
503505 (discon'''', graph'''') <- evalGraphOp tempBranchTransId discon''' graph''' (DeleteBranch tempBranchName)
504−
506+ {-
505507 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
506508 traceShowM rel
509+-}
507510 pure (discon'''', graph'''')
508511
509512
test/MultiProcessDatabaseAccess.hs+2−9
@@ -19,13 +19,6 @@ assertIOEither x = do
1919 Left err -> assertFailure (show err) >> undefined
2020 Right val -> pure val
2121
22−assertIONothing :: (Show a) => IO (Maybe a) -> IO ()
23−assertIONothing x = do
24− ret <- x
25− case ret of
26− Nothing -> pure ()
27− Just err -> assertFailure (show err)
28−
2922testList :: Test
3023testList = TestList [testMultipleProcessAccess]
3124
@@ -38,8 +31,8 @@ testMultipleProcessAccess = TestCase $ do
3831 dbdir = tmpdir </> "db"
3932 conn1 <- assertIOEither $ connectProjectM36 connInfo
4033 conn2 <- assertIOEither $ connectProjectM36 connInfo
41− session1 <- assertIOEither (createSessionAtHead master conn1)
42− session2 <- assertIOEither (createSessionAtHead master conn2)
34+ session1 <- assertIOEither (createSessionAtHead conn1 master)
35+ session2 <- assertIOEither (createSessionAtHead conn2 master)
4336 --add a commit on conn1 which conn2 doesn't know about
4437 assertIOEither $ executeDatabaseContextExpr session1 conn1 dudExpr
4538 assertIOEither $ commit session1 conn1
test/Server/Main.hs+3−3
@@ -72,7 +72,7 @@ testConnection serverAddress mvar = do
7272 case eConn of
7373 Left err -> pure $ Left err
7474 Right conn -> do
75− eSessionId <- createSessionAtHead defaultHeadName conn
75+ eSessionId <- createSessionAtHead conn defaultHeadName
7676 case eSessionId of
7777 Left _ -> error "failed to create session"
7878 Right sessionId -> pure $ Right (sessionId, conn)
@@ -169,7 +169,7 @@ testRelationVariableSummary sessionId conn = TestCase $ do
169169testSession :: SessionId -> Connection -> Test
170170testSession _ conn = TestCase $ do
171171 -- create and close a new session using AtHead and AtCommit
172− eSessionId1 <- createSessionAtHead defaultHeadName conn
172+ eSessionId1 <- createSessionAtHead conn defaultHeadName
173173 case eSessionId1 of
174174 Left _ -> assertFailure "invalid session"
175175 Right sessionId1 -> do
@@ -177,7 +177,7 @@ testSession _ conn = TestCase $ do
177177 case eHeadId of
178178 Left err -> assertFailure ("invalid head id: " ++ show err)
179179 Right headId -> do
180− eSessionId2 <- createSessionAtCommit headId conn
180+ eSessionId2 <- createSessionAtCommit conn headId
181181 assertBool ("invalid session: " ++ show eSessionId2) (isRight eSessionId2)
182182 closeSession sessionId1 conn
183183
test/TransactionGraph/Merge.hs+44−5
@@ -6,15 +6,18 @@ import ProjectM36.Relation
66import ProjectM36.Transaction
77import ProjectM36.TransactionGraph
88import ProjectM36.Error
9+import ProjectM36.Key
10+import qualified ProjectM36.DisconnectedTransaction as Discon
11+import qualified ProjectM36.DatabaseContext as DBC
12+import ProjectM36.RelationalExpression
13+
914import qualified Data.ByteString.Lazy as BS
1015import System.Exit
1116import Data.Word
12−import ProjectM36.RelationalExpression
13−import qualified ProjectM36.DisconnectedTransaction as Discon
1417import qualified Data.UUID as U
1518import qualified Data.Set as S
1619import qualified Data.Map as M
17−import qualified ProjectM36.DatabaseContext as DBC
20+
1821import Control.Monad.State hiding (join)
1922
2023main :: IO ()
@@ -29,7 +32,8 @@ testList = TestList [
2932 testSubGraphToFirstAncestorMoreTransactions,
3033 testSelectedBranchMerge,
3134 testUnionMergeStrategy,
32− testUnionPreferMergeStrategy
35+ testUnionPreferMergeStrategy,
36+ testUnionMergeIncDepViolation
3337 ]
3438
3539-- | Create a transaction graph with two branches and no changes between them.
@@ -44,7 +48,7 @@ createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty)
4448
4549basicTransactionGraph :: IO TransactionGraph
4650basicTransactionGraph = do
47− let bsGraph = bootstrapTransactionGraph uuidRoot DBC.empty --dateExamples
51+ let bsGraph = bootstrapTransactionGraph uuidRoot DBC.basicDatabaseContext
4852 rootTrans = case transactionForHead "master" bsGraph of
4953 Just trans -> trans
5054 Nothing -> error "bonk"
@@ -221,3 +225,38 @@ testUnionMergeStrategy = TestCase $ do
221225 case failingMerge of
222226 Right _ -> assertFailure "expected merge failure"
223227 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)
228+
229+-- test that a merge will fail if a constraint is violated
230+testUnionMergeIncDepViolation :: Test
231+testUnionMergeIncDepViolation = TestCase $ do
232+ graph <- basicTransactionGraph
233+ assertGraph graph
234+
235+ branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
236+ branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
237+
238+ --add relvar and key constraint to both branches
239+ let eRel val = mkRelationFromList (attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 1, IntAtom val]]
240+ rvName = "x"
241+ Right branchArv = eRel 2
242+ Right branchBrv = eRel 3
243+ branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchArv}
244+ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchBrv,
245+ inclusionDependencies = M.singleton incDepName incDep}
246+ incDepName = "x_key"
247+ incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())
248+
249+
250+ --add the rv in new commits to both branches
251+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) branchBContext) graph
252+
253+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) branchAContext) graph'
254+
255+ --check that the union merge fails due to a violated constraint
256+ let eMerge = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''
257+ case eMerge of
258+ Left (InclusionDependencyCheckError incDepName) -> pure ()
259+ Left err -> assertFailure ("other error: " ++ show err)
260+ Right trans -> do
261+ assertFailure "constraint violation missing"
262+
test/TransactionGraph/Persist.hs+2−2
@@ -72,7 +72,7 @@ testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp
7272 let dbdir = tempdir </> "dbdir"
7373 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
7474 Right conn <- connectProjectM36 connInfo
75− Right sess <- createSessionAtHead "master" conn
75+ Right sess <- createSessionAtHead conn "master"
7676 let intTCons = PrimitiveTypeConstructor "Int" IntAtomType
7777 addfunc = AddAtomFunction "testdisk" [
7878 intTCons,
@@ -83,7 +83,7 @@ testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp
8383 close conn
8484 --re-open the connection to reload the graph
8585 Right conn2 <- connectProjectM36 connInfo
86− Right sess2 <- createSessionAtHead "master" conn2
86+ Right sess2 <- createSessionAtHead conn2 "master"
8787
8888 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])
8989 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]