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

git.iko.soy/project-m36

on master help sign in

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

91d6fa9AgentM9 years ago

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

compare with master

unifiedsplit

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

14import TutorialD.Interpreter.Base

15import ProjectM36.Client

16import Control.Exception

17−import Data.Maybe (fromMaybe)

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

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

20websocketProxyServer port host pending = do

19websocketProxyServer port host pending = do

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

87-- get current schema and head name for client

86-- get current schema and head name for client

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

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

89promptInfo sessionId conn = do

88promptInfo sessionId conn = do

90− mHeadName <- headName sessionId conn

89+ eHeadName <- headName sessionId conn

91− mSchemaName <- currentSchemaName sessionId conn

90+ eSchemaName <- currentSchemaName sessionId conn

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

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

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

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

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

94sendPromptInfo (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)

88--execute the operation and display result

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

90evalTutorialD sessionId conn safe expr = case expr of

91−

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

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

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

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

94 (RODatabaseContextOp execOp) -> do

93 (RODatabaseContextOp execOp) -> do

95 evalRODatabaseContextOp sessionId conn execOp

94 evalRODatabaseContextOp sessionId conn execOp

97 (DatabaseContextExprOp execOp) -> do

96 (DatabaseContextExprOp execOp) -> do

98− maybeErr <- C.executeDatabaseContextExpr sessionId conn execOp

97+ eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

99− case maybeErr of

100− Left err -> barf err

101− Right () -> return QuietSuccessResult

102

103 (DatabaseContextIOExprOp execOp) -> do

99 (DatabaseContextIOExprOp execOp) -> do

104 if needsSafe then

100 if needsSafe then

105 unsafeError

101 unsafeError

106 else do

102 else do

107− mErr <- C.executeDatabaseContextIOExpr sessionId conn execOp

103+ eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp

108− case mErr of

109− Just err -> barf err

110− Nothing -> pure QuietSuccessResult

111

104

112 (GraphOp execOp) -> do

105 (GraphOp execOp) -> do

113− maybeErr <- C.executeGraphExpr sessionId conn execOp

106+ eHandler $ C.executeGraphExpr sessionId conn execOp

114− case maybeErr of

115− Left err -> barf err

116− Right () -> return QuietSuccessResult

117

107

118 (ROGraphOp execOp) -> do

108 (ROGraphOp execOp) -> do

119 opResult <- evalROGraphOp sessionId conn execOp

109 opResult <- evalROGraphOp sessionId conn execOp

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

122 Right rel -> pure (DisplayRelationResult rel)

112 Right rel -> pure (DisplayRelationResult rel)

123

113

124 (SchemaOp execOp) -> do

114 (SchemaOp execOp) -> do

125− opResult <- evalSchemaOperator sessionId conn execOp

115+ eHandler $ evalSchemaOperator sessionId conn execOp

126− case opResult of

127− Left err -> barf err

128− Right () -> pure QuietSuccessResult

129

116

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

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

131 if needsSafe then

118 if needsSafe then

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

146 if needsSafe then

133 if needsSafe then

147 unsafeError

134 unsafeError

148 else do

135 else do

149− mDbexprs <- evalDatabaseContextDataImportOperator execOp

136+ eErr <- evalDatabaseContextDataImportOperator execOp

150− case mDbexprs of

137+ case eErr of

151 Left err -> barf err

138 Left err -> barf err

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

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

153

140

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

181 needsSafe = safe == SafeEvaluation

168 needsSafe = safe == SafeEvaluation

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

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

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

170 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+

185type GhcPkgPath = String

177type GhcPkgPath = String

186data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |

178data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |

187 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

179 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

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

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

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

430--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.

431

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−

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

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

439excEither m = handle handler m

433excEither m = handle handler m

440 where

434 where

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

579

573

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

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

581--this is almost completely identical to executeDatabaseContextExpr above

575--this is almost completely identical to executeDatabaseContextExpr above

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

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

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

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

584 let sessions = ipSessions conf

578 let sessions = ipSessions conf

585 scriptSession = ipScriptSession conf

579 scriptSession = ipScriptSession conf

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

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

587 case eSession of

581 case eSession of

588− Left err -> pure $ Just err

582+ Left err -> pure (Left err)

589 Right session -> do

583 Right session -> do

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

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

591 case res of

585 case res of

592− Left err -> pure (Just err)

586+ Left err -> pure (Left err)

593 Right context' -> do

587 Right context' -> do

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

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

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

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

596 newSession = Session newDiscon (Sess.schemaName session)

590 newSession = Session newDiscon (Sess.schemaName session)

597 atomically $ STMMap.insert newSession sessionId sessions

591 atomically $ STMMap.insert newSession sessionId sessions

598− pure Nothing

592+ pure (Right ())

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

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

600

594

601{-

595{-

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

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

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

41 reply ret conn

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

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

44handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do

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

46 reply ret conn

test/Server/Main.hs+20−23

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

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

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

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

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

102+eitherFail (Right _) = pure ()

103+

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

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

101testSchemaExpr :: SessionId -> Connection -> Test

105testSchemaExpr :: SessionId -> Connection -> Test

102testSchemaExpr sessionId conn = TestCase $ do

106testSchemaExpr sessionId conn = TestCase $ do

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

107 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

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

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

106− assertEqual "executeSchemaExpr2" Nothing result'

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

107

111

108testDatabaseContextExpr :: SessionId -> Connection -> Test

112testDatabaseContextExpr :: SessionId -> Connection -> Test

109testDatabaseContextExpr sessionId conn = TestCase $ do

113testDatabaseContextExpr sessionId conn = TestCase $ do

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

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

111 attrs = attributesFromList [Attribute "x" TextAtomType]

115 attrs = attributesFromList [Attribute "x" TextAtomType]

112 testrv = "testrv"

116 testrv = "testrv"

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

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

114− case dbResult of

115− Just err -> assertFailure (show err)

116− Nothing -> do

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

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

118− let expected = mkRelation attrs emptyTupleSet

119+ let expected = mkRelation attrs emptyTupleSet

119− case eRel of

120+ case eRel of

120− Left err -> assertFailure (show err)

121+ Left err -> assertFailure (show err)

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

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

122

123

123testGraphExpr :: SessionId -> Connection -> Test

124testGraphExpr :: SessionId -> Connection -> Test

124testGraphExpr sessionId conn = TestCase $ do

125testGraphExpr sessionId conn = TestCase $ do

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

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

126− case graphResult of

127− Just err -> assertFailure (show err)

128− Nothing -> pure ()

129

127

130testTypeForRelationalExpr :: SessionId -> Connection -> Test

128testTypeForRelationalExpr :: SessionId -> Connection -> Test

131testTypeForRelationalExpr sessionId conn = TestCase $ do

129testTypeForRelationalExpr sessionId conn = TestCase $ do

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

159

157

160testHeadName :: SessionId -> Connection -> Test

158testHeadName :: SessionId -> Connection -> Test

161testHeadName sessionId conn = TestCase $ do

159testHeadName sessionId conn = TestCase $ do

162− mHeadName <- headName sessionId conn

160+ eHeadName <- headName sessionId conn

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

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

164

162

165testRelationVariableSummary :: SessionId -> Connection -> Test

163testRelationVariableSummary :: SessionId -> Connection -> Test

166testRelationVariableSummary sessionId conn = TestCase $ do

164testRelationVariableSummary sessionId conn = TestCase $ do

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

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

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

192testNotification mvar sess conn = TestCase $ do

190testNotification mvar sess conn = TestCase $ do

193 let relvarx = RelationVariable "x" ()

191 let relvarx = RelationVariable "x" ()

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

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

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

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

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

197− check $ commit sess conn ForbidEmptyCommitOption

194+ commit sess conn >>= eitherFail

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

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

199− check $ commit sess conn ForbidEmptyCommitOption

196+ commit sess conn >>= eitherFail

200 takeMVar mvar

197 takeMVar mvar

201

198

202testRequestTimeout :: Test

199testRequestTimeout :: Test

test/TransactionGraph/Persist.hs+2−2

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

78 intTCons,

79 ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [],

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

81− Nothing <- executeDatabaseContextIOExpr sess conn addfunc

81+ Right () <- executeDatabaseContextIOExpr sess conn addfunc

82− Nothing <- commit sess conn ForbidEmptyCommitOption

82+ Right () <- commit sess conn

83 close conn

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

85 Right conn2 <- connectProjectM36 connInfo

test/TutorialD/Interpreter.hs+47−66

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

160 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"

161 DisplayErrorResult err -> assertFailure (show err)

162 QuietSuccessResult -> do

163− commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail

163+ commit sessionId dbconn >>= eitherFail

164 discon <- disconnectedTransaction_ sessionId dbconn

165 let context = Discon.concreteDatabaseContext discon

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

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

169transactionRollbackTest = TestCase $ do

170 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

171 graph <- transactionGraph_ dbconn

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

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

173− case maybeErr of

174− Just err -> assertFailure (show err)

175− Nothing -> do

176− rollback sessionId dbconn >>= maybeFail

173+ rollback sessionId dbconn >>= eitherFail

177− discon <- disconnectedTransaction_ sessionId dbconn

174+ discon <- disconnectedTransaction_ sessionId dbconn

178− graph' <- transactionGraph_ dbconn

175+ graph' <- transactionGraph_ dbconn

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

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

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

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

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

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

182

179

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

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

184transactionJumpTest :: Test

181transactionJumpTest :: Test

185transactionJumpTest = TestCase $ do

182transactionJumpTest = TestCase $ do

186 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

183 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

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

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

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

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

189− case maybeErr of

190− Just err -> assertFailure (show err)

191− Nothing -> do

192− commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail

186+ commit sessionId dbconn >>= eitherFail

193− --perform the jump

187+ --perform the jump

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

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

195− case maybeErr2 of

196− Just err -> assertFailure (show err)

197− Nothing -> do

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

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

199− discon <- disconnectedTransaction_ sessionId dbconn

190+ discon <- disconnectedTransaction_ sessionId dbconn

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

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

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

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

202transactionBranchTest :: Test

193transactionBranchTest :: Test

203transactionBranchTest = TestCase $ do

194transactionBranchTest = TestCase $ do

204 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

195 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

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

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

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

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

207− commit sessionId dbconn ForbidEmptyCommitOption,

198+ commit sessionId dbconn,

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

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

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

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

210 ]

201 ]

211 graph <- transactionGraph_ dbconn

202 graph <- transactionGraph_ dbconn

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

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

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

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

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

256 relvarx = RelationVariable "x" ()

247 relvarx = RelationVariable "x" ()

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

248 (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))

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

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

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

261− check' $ commit sess conn ForbidEmptyCommitOption

251+ commit sess conn >>= eitherFail

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

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

263− check' $ commit sess conn ForbidEmptyCommitOption

253+ commit sess conn >>= eitherFail

264 takeMVar notifmvar

254 takeMVar notifmvar

265

255

266testTypeConstructors :: Test

256testTypeConstructors :: Test

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

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

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

361 lightProduct <- assertEither eLightProduct

351 lightProduct <- assertEither eLightProduct

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

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

363− mErr <- setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName

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

364− case mErr of

365− Just err -> assertFailure (show err)

366− Nothing -> do

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

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

368− restrictedProduct <- assertEither eRestrictedProduct

355+ restrictedProduct <- assertEither eRestrictedProduct

369− assertEqual "light product" restrictedProduct lightProduct

356+ assertEqual "light product" restrictedProduct lightProduct

370

357

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

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

372assertEither x = case x of

359assertEither x = case x of

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

402testEmptyCommits :: Test

389testEmptyCommits :: Test

403testEmptyCommits = TestCase $ do

390testEmptyCommits = TestCase $ do

404 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

391 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

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

392+ dirty <- disconnectedTransactionIsDirty sessionId dbconn

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

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

394+ Right () <- commit sessionId dbconn

395+

407 --insert no tuples

396 --insert no tuples

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

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

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

398+ dirty' <- disconnectedTransactionIsDirty sessionId dbconn

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

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

400+ Right () <- commit sessionId dbconn

401+

411 --update no tuples

402 --update no tuples

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

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

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

404+ dirty'' <- disconnectedTransactionIsDirty sessionId dbconn

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

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

415− --delete no tuples

406+ Right () <- commit sessionId dbconn

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

419

407

420− --test allow empty commit option

408+ --delete no tuples

421− headId5 <- headTransactionId sessionId dbconn

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

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

410+ dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

423− assertEqual "allow empty commit" Nothing err5

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

424− headId5' <- headTransactionId sessionId dbconn

412+

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

426

413

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

1module TutorialD.Interpreter.TestBase where

2import ProjectM36.Client

3+import ProjectM36.Error

3import TutorialD.Interpreter

4import TutorialD.Interpreter

4import TutorialD.Interpreter.Base

5import TutorialD.Interpreter.Base

5import qualified ProjectM36.Base as Base

6import qualified ProjectM36.Base as Base

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

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

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

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

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

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

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

25− commit sessionId conn ForbidEmptyCommitOption >>= maybeFail

26+ commit sessionId conn >>= eitherFail

26 pure (sessionId, conn)

27 pure (sessionId, conn)

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

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

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

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

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

54 QuietSuccessResult -> pure ()

55 QuietSuccessResult -> pure ()

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

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

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

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

58−maybeFail Nothing = return ()

59+eitherFail (Right _) = pure ()