91d6fa9 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP test updates for switch from Maybe to Either for Client API

commit91d6fa9e3fe3cf8747ba0d68743513faf57e0bf7 authorAgentM <agentm@themactionfaction.com> dateSun 30 Jul 2017, 00:19 (9 years ago) parentf0825a5

8 files changed+95−131

compare with master

unifiedsplit

src/bin/ProjectM36/Server/WebSocket.hs+3−4 src/bin/TutorialD/Interpreter.hs+12−20 src/lib/ProjectM36/Client.hs+5−11 src/lib/ProjectM36/Server/EntryPoints.hs+1−1 test/Server/Main.hs+20−23 test/TransactionGraph/Persist.hs+2−2 test/TutorialD/Interpreter.hs+47−66 test/TutorialD/Interpreter/TestBase.hs+5−4

src/bin/ProjectM36/Server/WebSocket.hs+3−4

@@ -14,7 +14,6 @@ import TutorialD.Interpreter

1414import TutorialD.Interpreter.Base

1515import ProjectM36.Client

1616import Control.Exception

17−import Data.Maybe (fromMaybe)

1817

1918websocketProxyServer :: Port -> Hostname -> WS.ServerApp

2019websocketProxyServer port host pending = do

@@ -87,9 +86,9 @@ handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode

8786-- get current schema and head name for client

8887promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

8988promptInfo sessionId conn = do

90− mHeadName <- headName sessionId conn

91− mSchemaName <- currentSchemaName sessionId conn

92− pure (fromMaybe "<unknown>" mHeadName, fromMaybe "<no schema>" mSchemaName)

89+ eHeadName <- headName sessionId conn

90+ eSchemaName <- currentSchemaName sessionId conn

91+ pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)

9392

9493sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

9594sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

src/bin/TutorialD/Interpreter.hs+12−20

@@ -88,32 +88,22 @@ data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)

8888--execute the operation and display result

8989evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO (TutorialDOperatorResult)

9090evalTutorialD sessionId conn safe expr = case expr of

91−

9291 --this does not pass through the ProjectM36.Client library because the operations

9392 --are specific to the interpreter, though some operations may be of general use in the future

9493 (RODatabaseContextOp execOp) -> do

9594 evalRODatabaseContextOp sessionId conn execOp

9695

9796 (DatabaseContextExprOp execOp) -> do

98− maybeErr <- C.executeDatabaseContextExpr sessionId conn execOp

99− case maybeErr of

100− Left err -> barf err

101− Right () -> return QuietSuccessResult

97+ eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

10298

10399 (DatabaseContextIOExprOp execOp) -> do

104100 if needsSafe then

105101 unsafeError

106102 else do

107− mErr <- C.executeDatabaseContextIOExpr sessionId conn execOp

108− case mErr of

109− Just err -> barf err

110− Nothing -> pure QuietSuccessResult

103+ eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp

111104

112105 (GraphOp execOp) -> do

113− maybeErr <- C.executeGraphExpr sessionId conn execOp

114− case maybeErr of

115− Left err -> barf err

116− Right () -> return QuietSuccessResult

106+ eHandler $ C.executeGraphExpr sessionId conn execOp

117107

118108 (ROGraphOp execOp) -> do

119109 opResult <- evalROGraphOp sessionId conn execOp

@@ -122,10 +112,7 @@ evalTutorialD sessionId conn safe expr = case expr of

122112 Right rel -> pure (DisplayRelationResult rel)

123113

124114 (SchemaOp execOp) -> do

125− opResult <- evalSchemaOperator sessionId conn execOp

126− case opResult of

127− Left err -> barf err

128− Right () -> pure QuietSuccessResult

115+ eHandler $ evalSchemaOperator sessionId conn execOp

129116

130117 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do

131118 if needsSafe then

@@ -146,8 +133,8 @@ evalTutorialD sessionId conn safe expr = case expr of

146133 if needsSafe then

147134 unsafeError

148135 else do

149− mDbexprs <- evalDatabaseContextDataImportOperator execOp

150− case mDbexprs of

136+ eErr <- evalDatabaseContextDataImportOperator execOp

137+ case eErr of

151138 Left err -> barf err

152139 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)

153140

@@ -181,7 +168,12 @@ evalTutorialD sessionId conn safe expr = case expr of

181168 needsSafe = safe == SafeEvaluation

182169 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

183170 barf err = return $ DisplayErrorResult (T.pack (show err))

184−

171+ eHandler io = do

172+ eErr <- io

173+ case eErr of

174+ Left err -> barf err

175+ Right () -> return QuietSuccessResult

176+

185177type GhcPkgPath = String

186178data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |

187179 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

src/lib/ProjectM36/Client.hs+5−11

@@ -429,12 +429,6 @@ closeRemote_ (RemoteProcessConnection conf) = runProcess (rLocalNode conf) (reco

429429--within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases

430430--exceptions should generally *NOT* be thrown from any Project:M36 code paths, but third-party code such as AtomFunction scripts could conceivably throw undefined, etc.

431431

432−excMaybe :: IO (Maybe RelationalError) -> IO (Maybe RelationalError)

433−excMaybe m = handle handler m

434− where

435− handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc

436− | otherwise = pure (Just (UnhandledExceptionError (show exc)))

437−

438432excEither :: IO (Either RelationalError a) -> IO (Either RelationalError a)

439433excEither m = handle handler m

440434 where

@@ -579,23 +573,23 @@ autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = rem

579573

580574-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr` modify the DatabaseContext but cannot be purely implemented.

581575--this is almost completely identical to executeDatabaseContextExpr above

582−executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError)

583−executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excMaybe $ do

576+executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Either RelationalError ())

577+executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEither $ do

584578 let sessions = ipSessions conf

585579 scriptSession = ipScriptSession conf

586580 eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO?

587581 case eSession of

588− Left err -> pure $ Just err

582+ Left err -> pure (Left err)

589583 Right session -> do

590584 res <- RE.evalDatabaseContextIOExpr scriptSession (Sess.concreteDatabaseContext session) expr

591585 case res of

592− Left err -> pure (Just err)

586+ Left err -> pure (Left err)

593587 Right context' -> do

594588 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True

595589 newSchemas = Schemas context' (Sess.subschemas session)

596590 newSession = Session newDiscon (Sess.schemaName session)

597591 atomically $ STMMap.insert newSession sessionId sessions

598− pure Nothing

592+ pure (Right ())

599593executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

600594

601595{-

src/lib/ProjectM36/Server/EntryPoints.hs+1−1

@@ -40,7 +40,7 @@ handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do

4040 ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)

4141 reply ret conn

4242

43−handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Maybe RelationalError)

43+handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ())

4444handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do

4545 ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)

4646 reply ret conn

test/Server/Main.hs+20−23

@@ -97,35 +97,33 @@ testRelationalExpr sessionId conn = TestCase $ do

9797 relResult <- executeRelationalExpr sessionId conn (RelationVariable "true" ())

9898 assertEqual "invalid relation result" (Right relationTrue) relResult

9999

100+eitherFail :: (Show e) => Either e a -> IO ()

101+eitherFail (Left err) = assertFailure (show err)

102+eitherFail (Right _) = pure ()

103+

100104-- test adding an removing a schema against true/false relations

101105testSchemaExpr :: SessionId -> Connection -> Test

102106testSchemaExpr sessionId conn = TestCase $ do

103107 result <- executeSchemaExpr sessionId conn (AddSubschema "test-schema" [IsoRename "table_dee" "true", IsoRename "table_dum" "false"])

104− assertEqual "executeSchemaExpr" Nothing result

108+ assertEqual "executeSchemaExpr" (Right ()) result

105109 result' <- executeSchemaExpr sessionId conn (RemoveSubschema "test-schema")

106− assertEqual "executeSchemaExpr2" Nothing result'

110+ assertEqual "executeSchemaExpr2" (Right ()) result'

107111

108112testDatabaseContextExpr :: SessionId -> Connection -> Test

109113testDatabaseContextExpr sessionId conn = TestCase $ do

110114 let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Text" TextAtomType) ()]

111115 attrs = attributesFromList [Attribute "x" TextAtomType]

112116 testrv = "testrv"

113− dbResult <- executeDatabaseContextExpr sessionId conn (Define testrv attrExprs)

114− case dbResult of

115− Just err -> assertFailure (show err)

116− Nothing -> do

117− eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ())

118− let expected = mkRelation attrs emptyTupleSet

119− case eRel of

120− Left err -> assertFailure (show err)

121− Right rel -> assertEqual "dbcontext definition failed" expected (Right rel)

117+ executeDatabaseContextExpr sessionId conn (Define testrv attrExprs) >>= eitherFail

118+ eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ())

119+ let expected = mkRelation attrs emptyTupleSet

120+ case eRel of

121+ Left err -> assertFailure (show err)

122+ Right rel -> assertEqual "dbcontext definition failed" expected (Right rel)

122123

123124testGraphExpr :: SessionId -> Connection -> Test

124125testGraphExpr sessionId conn = TestCase $ do

125− graphResult <- executeGraphExpr sessionId conn (JumpToHead "master")

126− case graphResult of

127− Just err -> assertFailure (show err)

128− Nothing -> pure ()

126+ executeGraphExpr sessionId conn (JumpToHead "master") >>= eitherFail

129127

130128testTypeForRelationalExpr :: SessionId -> Connection -> Test

131129testTypeForRelationalExpr sessionId conn = TestCase $ do

@@ -159,8 +157,8 @@ testHeadTransactionId sessionId conn = TestCase $ do

159157

160158testHeadName :: SessionId -> Connection -> Test

161159testHeadName sessionId conn = TestCase $ do

162− mHeadName <- headName sessionId conn

163− assertEqual "headName failure" (Just "master") mHeadName

160+ eHeadName <- headName sessionId conn

161+ assertEqual "headName failure" (Right "master") eHeadName

164162

165163testRelationVariableSummary :: SessionId -> Connection -> Test

166164testRelationVariableSummary sessionId conn = TestCase $ do

@@ -191,12 +189,11 @@ testNotificationCallback mvar _ _ = putMVar mvar ()

191189testNotification :: MVar () -> SessionId -> Connection -> Test

192190testNotification mvar sess conn = TestCase $ do

193191 let relvarx = RelationVariable "x" ()

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

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

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

197− check $ commit sess conn ForbidEmptyCommitOption

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

199− check $ commit sess conn ForbidEmptyCommitOption

192+ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail

193+ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail

194+ commit sess conn >>= eitherFail

195+ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail

196+ commit sess conn >>= eitherFail

200197 takeMVar mvar

201198

202199testRequestTimeout :: Test

test/TransactionGraph/Persist.hs+2−2

@@ -78,8 +78,8 @@ testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

7878 intTCons,

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

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

81− Nothing <- executeDatabaseContextIOExpr sess conn addfunc

82− Nothing <- commit sess conn ForbidEmptyCommitOption

81+ Right () <- executeDatabaseContextIOExpr sess conn addfunc

82+ Right () <- commit sess conn

8383 close conn

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

8585 Right conn2 <- connectProjectM36 connInfo

test/TutorialD/Interpreter.hs+47−66

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

160160 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"

161161 DisplayErrorResult err -> assertFailure (show err)

162162 QuietSuccessResult -> do

163− commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail

163+ commit sessionId dbconn >>= eitherFail

164164 discon <- disconnectedTransaction_ sessionId dbconn

165165 let context = Discon.concreteDatabaseContext discon

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

@@ -169,44 +169,35 @@ transactionRollbackTest :: Test

169169transactionRollbackTest = TestCase $ do

170170 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

171171 graph <- transactionGraph_ dbconn

172− maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ()))

173− case maybeErr of

174− Just err -> assertFailure (show err)

175− Nothing -> do

176− rollback sessionId dbconn >>= maybeFail

177− discon <- disconnectedTransaction_ sessionId dbconn

178− graph' <- transactionGraph_ dbconn

179− assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))

180− let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

181− assertEqual "validate graph" (graphEq graph) (graphEq graph')

172+ executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail

173+ rollback sessionId dbconn >>= eitherFail

174+ discon <- disconnectedTransaction_ sessionId dbconn

175+ graph' <- transactionGraph_ dbconn

176+ assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))

177+ let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

178+ assertEqual "validate graph" (graphEq graph) (graphEq graph')

182179

183180--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present

184181transactionJumpTest :: Test

185182transactionJumpTest = TestCase $ do

186183 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

187184 (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn

188− maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ()))

189− case maybeErr of

190− Just err -> assertFailure (show err)

191− Nothing -> do

192− commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail

193− --perform the jump

194− maybeErr2 <- executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID)

195− case maybeErr2 of

196− Just err -> assertFailure (show err)

197− Nothing -> do

198− --check that the disconnected transaction does not include "x"

199− discon <- disconnectedTransaction_ sessionId dbconn

200− assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))

185+ executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail

186+ commit sessionId dbconn >>= eitherFail

187+ --perform the jump

188+ executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail

189+ --check that the disconnected transaction does not include "x"

190+ discon <- disconnectedTransaction_ sessionId dbconn

191+ assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))

201192--branch from the first transaction and verify that there are two heads

202193transactionBranchTest :: Test

203194transactionBranchTest = TestCase $ do

204195 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

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

206− executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),

207− commit sessionId dbconn ForbidEmptyCommitOption,

208− executeGraphExpr sessionId dbconn (JumpToHead "master"),

209− executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))

196+ mapM_ (\x -> x >>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),

197+ executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),

198+ commit sessionId dbconn,

199+ executeGraphExpr sessionId dbconn (JumpToHead "master"),

200+ executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))

210201 ]

211202 graph <- transactionGraph_ dbconn

212203 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)

@@ -255,12 +246,11 @@ testNotification = TestCase $ do

255246 let notifCallback mvar = \_ _ -> putMVar mvar ()

256247 relvarx = RelationVariable "x" ()

257248 (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)

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

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

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

261− check' $ commit sess conn ForbidEmptyCommitOption

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

263− check' $ commit sess conn ForbidEmptyCommitOption

249+ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail

250+ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail

251+ commit sess conn >>= eitherFail

252+ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail

253+ commit sess conn >>= eitherFail

264254 takeMVar notifmvar

265255

266256testTypeConstructors :: Test

@@ -360,13 +350,10 @@ testSchemaExpr = TestCase $ do

360350 eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())

361351 lightProduct <- assertEither eLightProduct

362352 let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntAtom 17), AttributeAtomExpr "weight"] ()))

363− mErr <- setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName

364− case mErr of

365− Just err -> assertFailure (show err)

366− Nothing -> do

367− eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))

368− restrictedProduct <- assertEither eRestrictedProduct

369− assertEqual "light product" restrictedProduct lightProduct

353+ setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail

354+ eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))

355+ restrictedProduct <- assertEither eRestrictedProduct

356+ assertEqual "light product" restrictedProduct lightProduct

370357

371358assertEither :: (Show a) => Either a b -> IO b

372359assertEither x = case x of

@@ -402,31 +389,25 @@ testFunctionalDependencies = TestCase $ do

402389testEmptyCommits :: Test

403390testEmptyCommits = TestCase $ do

404391 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

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

406− assertEqual "no updates empty commit" (Just EmptyCommitError) err1

392+ dirty <- disconnectedTransactionIsDirty sessionId dbconn

393+ assertEqual "no change not dirty" (Right False) dirty

394+ Right () <- commit sessionId dbconn

395+

407396 --insert no tuples

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

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

410− assertEqual "empty insert empty commit" (Just EmptyCommitError) err2

397+ Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))

398+ dirty' <- disconnectedTransactionIsDirty sessionId dbconn

399+ assertEqual "empty insert empty commit" (Right False) dirty'

400+ Right () <- commit sessionId dbconn

401+

411402 --update no tuples

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

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

414− assertEqual "empty update empty commit" (Just EmptyCommitError) err3

415− --delete no tuples

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

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

418− assertEqual "empty delete empty commit" (Just EmptyCommitError) err4

403+ Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

404+ dirty'' <- disconnectedTransactionIsDirty sessionId dbconn

405+ assertEqual "empty update empty commit" (Right False) dirty''

406+ Right () <- commit sessionId dbconn

419407

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

408+ --delete no tuples

409+ Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

410+ dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

411+ assertEqual "empty delete empty commit" (Right False) dirty'''

412+

426413

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+5−4

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

11module TutorialD.Interpreter.TestBase where

22import ProjectM36.Client

3+import ProjectM36.Error

34import TutorialD.Interpreter

45import TutorialD.Interpreter.Base

56import qualified ProjectM36.Base as Base

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

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

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

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

25− commit sessionId conn ForbidEmptyCommitOption >>= maybeFail

26+ commit sessionId conn >>= eitherFail

2627 pure (sessionId, conn)

2728

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

@@ -53,6 +54,6 @@ expectTutorialDErr sessionId conn matchFunc tutd = case parseTutorialD tutd of

5354 DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err)

5455 QuietSuccessResult -> pure ()

5556

56−maybeFail :: (Show a) => Maybe a -> IO ()

57−maybeFail (Just err) = assertFailure (show err)

58−maybeFail Nothing = return ()

57+eitherFail :: Either RelationalError a -> IO ()

58+eitherFail (Left err) = assertFailure (show err)

59+eitherFail (Right _) = pure ()