d293692 · project-m36 · git.iko.soy

examples/SimpleClient.hs−1

@@ -1,6 +1,5 @@

11import ProjectM36.Client

22import ProjectM36.TupleSet

3−import ProjectM36.Base

43import ProjectM36.Relation.Show.Term

54

65main :: IO ()

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+1−1

@@ -34,7 +34,7 @@ deleteBranchP = do

3434commitTransactionP :: Parser TransactionGraphOperator

3535commitTransactionP = do

3636 reservedOp ":commit"

37− return $ Commit

37+ return $ Commit ForbidEmptyCommitOption

3838

3939rollbackTransactionP :: Parser TransactionGraphOperator

4040rollbackTransactionP = do

src/lib/ProjectM36/Client.hs+26−20

@@ -49,6 +49,7 @@ module ProjectM36.Client

4949 callTestTimeout_,

5050 RelationCardinality(..),

5151 TransactionGraphOperator(..),

52+ CommitOption(..),

5253 transactionGraph_,

5354 disconnectedTransaction_,

5455 TransGraphRelationalExpr,

@@ -614,7 +615,7 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excMaybe $ do

614615 graphTvar = ipTransactionGraph conf

615616 mLockFileH = ipLocks conf

616617 lockHandler body = case graphExpr of

617− Commit -> case mLockFileH of

618+ Commit _ -> case mLockFileH of

618619 Nothing -> body False

619620 Just (lockFileH, lockMVar) -> let acquireLocks = do

620621 lastWrittenDigest <- takeMVar lockMVar

@@ -653,22 +654,27 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excMaybe $ do

653654 case eRefreshedGraph of

654655 Left err -> pure (Left (DatabaseLoadError err))

655656 Right refreshedGraph -> do

656− eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar

657− case eGraph of

658− Left err -> pure (Left err)

659− Right newGraph -> do

660− --handle commit

661− if graphExpr == Commit then

662− if not (isDirty session) then pure (Left EmptyCommitError)

663− else do

664− case transactionForId (Sess.parentId session) oldGraph of

665− Left err -> pure $ Left err

666− Right previousTrans -> do

667− (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

668− nodesToNotify <- toList (STMSet.stream nodes)

669− pure $ Right (evaldNots, nodesToNotify, newGraph)

670− else

671− pure $ Right (M.empty, [], newGraph)

657+ if not (isDirty session) && graphExpr == Commit IgnoreEmptyCommitOption then

658+ pure (Right (M.empty, [], oldGraph))

659+ else do

660+ eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar

661+ case eGraph of

662+ Left err -> pure (Left err)

663+ Right newGraph -> do

664+ --handle commit

665+ if not (isDirty session) && graphExpr == Commit ForbidEmptyCommitOption then

666+ pure (Left EmptyCommitError)

667+ else if not (isDirty session) && graphExpr == Commit IgnoreEmptyCommitOption then

668+ pure (Right (M.empty, [], newGraph))

669+ else if isCommit graphExpr then do

670+ case transactionForId (Sess.parentId session) oldGraph of

671+ Left err -> pure $ Left err

672+ Right previousTrans -> do

673+ (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

674+ nodesToNotify <- toList (STMSet.stream nodes)

675+ pure $ Right (evaldNots, nodesToNotify, newGraph)

676+ else

677+ pure $ Right (M.empty, [], newGraph)

672678 case manip of

673679 Left err -> return $ Just err

674680 Right (notsToFire, nodesToNotify, newGraph) -> do

@@ -710,9 +716,9 @@ executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $

710716executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

711717

712718-- | After modifying a session, 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

713−commit :: SessionId -> Connection -> IO (Maybe RelationalError)

714−commit sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Commit

715−commit sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)

719+commit :: SessionId -> Connection -> CommitOption -> IO (Maybe RelationalError)

720+commit sessionId conn@(InProcessConnection _) cOpt = executeGraphExpr sessionId conn (Commit cOpt)

721+commit sessionId conn@(RemoteProcessConnection _) cOpt = remoteCall conn (ExecuteGraphExpr sessionId (Commit cOpt))

716722

717723sendNotifications :: [ProcessId] -> LocalNode -> EvaluatedNotifications -> IO ()

718724sendNotifications pids localNode nots = mapM_ sendNots pids

src/lib/ProjectM36/TransactionGraph.hs+12−4

@@ -28,20 +28,28 @@ data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- git

2828 TransactionIdHeadBranchBacktrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent

2929 deriving (Show, Eq, Binary, Generic)

3030

31+data CommitOption = AllowEmptyCommitOption | -- allow empty commit and add it to the graph

32+ ForbidEmptyCommitOption | --return error on empty commit- probably the safest option

33+ IgnoreEmptyCommitOption -- don't add the commit and don't add it to the graph (no-op)

34+ deriving (Eq, Show, Binary, Generic)

35+

3136--operators which manipulate a transaction graph

3237data TransactionGraphOperator = JumpToHead HeadName |

3338 JumpToTransaction TransactionId |

3439 Branch HeadName |

3540 DeleteBranch HeadName |

3641 MergeTransactions MergeStrategy HeadName HeadName |

37− Commit |

42+ Commit CommitOption |

3843 Rollback

3944 deriving (Eq, Show, Binary, Generic)

40−

45+

46+isCommit :: TransactionGraphOperator -> Bool

47+isCommit (Commit _) = True

48+isCommit _ = False

49+

4150data ROTransactionGraphOperator = ShowGraph

4251 deriving Show

4352

44−

4553bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph

4654bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

4755 where

@@ -223,7 +231,7 @@ evalGraphOp newId (DisconnectedTransaction parentId schemas' _) graph (Branch ne

223231

224232-- add the disconnected transaction to the graph

225233-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

226−evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of

234+evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph (Commit _) = case transactionForId parentId graph of

227235 Left err -> Left err

228236 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

229237 Nothing -> Left $ TransactionIsNotAHeadError parentId

test/MultiProcessDatabaseAccess.hs+2−2

@@ -42,12 +42,12 @@ testMultipleProcessAccess = TestCase $ do

4242 session2 <- assertIOEither (createSessionAtHead master conn2)

4343 --add a commit on conn1 which conn2 doesn't know about

4444 assertIONothing $ executeDatabaseContextExpr session1 conn1 dudExpr

45− assertIONothing $ commit session1 conn1

45+ assertIONothing $ commit session1 conn1 ForbidEmptyCommitOption

4646

4747 assertIONothing $ executeDatabaseContextExpr session2 conn2 dudExpr

4848 mHeadId <- headTransactionId session2 conn2

4949 headId <- case mHeadId of

5050 Nothing -> assertFailure "headTransactionId failed" >> undefined

5151 Just x -> pure x

52− res <- commit session2 conn2

52+ res <- commit session2 conn2 ForbidEmptyCommitOption

5353 assertEqual "commit should fail" (Just (TransactionIsNotAHeadError headId)) res

test/Server/Main.hs+2−2

@@ -194,9 +194,9 @@ testNotification mvar sess conn = TestCase $ do

194194 check x = x >>= maybe (pure ()) (\err -> assertFailure (show err))

195195 check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))

196196 check $ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx)

197− check $ commit sess conn

197+ check $ commit sess conn ForbidEmptyCommitOption

198198 check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse))

199− check $ commit sess conn

199+ check $ commit sess conn ForbidEmptyCommitOption

200200 takeMVar mvar

201201

202202testRequestTimeout :: Test

test/TransactionGraph/Persist.hs+1−1

@@ -79,7 +79,7 @@ testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

7979 ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [],

8080 intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"

8181 Nothing <- executeDatabaseContextIOExpr sess conn addfunc

82− Nothing <- commit sess conn

82+ Nothing <- commit sess conn ForbidEmptyCommitOption

8383 close conn

8484 --re-open the connection to reload the graph

8585 Right conn2 <- connectProjectM36 connInfo

test/TutorialD/Interpreter.hs+22−10

@@ -160,7 +160,7 @@ transactionGraphAddCommitTest = TestCase $ do

160160 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"

161161 DisplayErrorResult err -> assertFailure (show err)

162162 QuietSuccessResult -> do

163− commit sessionId dbconn >>= maybeFail

163+ commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail

164164 discon <- disconnectedTransaction_ sessionId dbconn

165165 let context = Discon.concreteDatabaseContext discon

166166 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)

@@ -189,7 +189,7 @@ transactionJumpTest = TestCase $ do

189189 case maybeErr of

190190 Just err -> assertFailure (show err)

191191 Nothing -> do

192− commit sessionId dbconn >>= maybeFail

192+ commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail

193193 --perform the jump

194194 maybeErr2 <- executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID)

195195 case maybeErr2 of

@@ -204,7 +204,7 @@ transactionBranchTest = TestCase $ do

204204 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

205205 mapM_ (\x -> x >>= maybeFail) [executeGraphExpr sessionId dbconn (Branch "test"),

206206 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),

207− commit sessionId dbconn,

207+ commit sessionId dbconn ForbidEmptyCommitOption,

208208 executeGraphExpr sessionId dbconn (JumpToHead "master"),

209209 executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))

210210 ]

@@ -258,9 +258,9 @@ testNotification = TestCase $ do

258258 let check' x = x >>= maybe (pure ()) (\err -> assertFailure (show err))

259259 check' $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))

260260 check' $ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx)

261− check' $ commit sess conn

261+ check' $ commit sess conn ForbidEmptyCommitOption

262262 check' $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse))

263− check' $ commit sess conn

263+ check' $ commit sess conn ForbidEmptyCommitOption

264264 takeMVar notifmvar

265265

266266testTypeConstructors :: Test

@@ -402,19 +402,31 @@ testFunctionalDependencies = TestCase $ do

402402testEmptyCommits :: Test

403403testEmptyCommits = TestCase $ do

404404 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

405− err1 <- executeGraphExpr sessionId dbconn Commit

405+ err1 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)

406406 assertEqual "no updates empty commit" (Just EmptyCommitError) err1

407407 --insert no tuples

408408 Nothing <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))

409− err2 <- executeGraphExpr sessionId dbconn Commit

409+ err2 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)

410410 assertEqual "empty insert empty commit" (Just EmptyCommitError) err2

411411 --update no tuples

412412 Nothing <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

413− err3 <- executeGraphExpr sessionId dbconn Commit

413+ err3 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)

414414 assertEqual "empty update empty commit" (Just EmptyCommitError) err3

415415 --delete no tuples

416416 Nothing <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

417− err4 <- executeGraphExpr sessionId dbconn Commit

417+ err4 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)

418418 assertEqual "empty delete empty commit" (Just EmptyCommitError) err4

419419

420−

420+ --test allow empty commit option

421+ headId5 <- headTransactionId sessionId dbconn

422+ err5 <- executeGraphExpr sessionId dbconn (Commit AllowEmptyCommitOption)

423+ assertEqual "allow empty commit" Nothing err5

424+ headId5' <- headTransactionId sessionId dbconn

425+ assertBool "different heads" (headId5 /= headId5')

426+

427+ --test ignore empty commit option

428+ headId6 <- headTransactionId sessionId dbconn

429+ err6 <- executeGraphExpr sessionId dbconn (Commit IgnoreEmptyCommitOption)

430+ assertEqual "ignore empty commit" Nothing err6

431+ headId6' <- headTransactionId sessionId dbconn

432+ assertEqual "same heads" headId6 headId6'

test/TutorialD/Interpreter/TestBase.hs+1−1

@@ -22,7 +22,7 @@ dateExamplesConnection callback = do

2222 mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr sessionId conn (Assign rvName (Base.ExistingRelation rvRel))) (M.toList (Base.relationVariables dateExamples))

2323 mapM_ (\(idName,incDep) -> executeDatabaseContextExpr sessionId conn (AddInclusionDependency idName incDep)) (M.toList incDeps)

2424 --skipping atom functions for now- there are no atom function manipulation operators yet

25− commit sessionId conn >>= maybeFail

25+ commit sessionId conn ForbidEmptyCommitOption >>= maybeFail

2626 pure (sessionId, conn)

2727

2828executeTutorialD :: SessionId -> Connection -> Text -> IO ()