aa37ec1 · project-m36 · git.iko.soy

git.iko.soy/project-m36

finish notification tests

commitaa37ec1566eb838f2857f32f81671abd78041f7d authorAgentM <agentm@themactionfaction.com> dateWed 27 Jan 2016, 23:27 (11 years ago) parent677dc7d

3 files changed+24−15

compare with master

unifiedsplit

ProjectM36/Client.hs+5−5 test/Server/Main.hs+2−2 test/TutorialD/Interpreter.hs+17−8

ProjectM36/Client.hs+5−5

@@ -60,13 +60,13 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPo

6060import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess)

6161import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

6262import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

63−import Control.Distributed.Process (NodeId(..), getSelfPid)

63+import Control.Distributed.Process (NodeId(..))

6464

6565import Data.UUID (UUID)

6666import Data.UUID.V4 (nextRandom)

6767import Control.Concurrent.STM

6868import Data.Word

69−import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match, say)

69+import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match)

7070import Control.Exception (IOException)

7171import Control.Concurrent.MVar

7272import qualified Data.Map as M

@@ -152,8 +152,8 @@ commonLocalNode = do

152152

153153notificationListener :: NotificationCallback -> Process ()

154154notificationListener callback = do

155− pid <- getSelfPid

156− liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid

155+ --pid <- getSelfPid

156+ --liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid

157157 _ <- forever $ do

158158 receiveWait [

159159 match (\(NotificationMessage eNots) -> do

@@ -161,7 +161,7 @@ notificationListener callback = do

161161 liftIO $ mapM_ (uncurry callback) (M.toList eNots)

162162 )

163163 ]

164− say "LISTENER THREAD EXIT"

164+ --say "LISTENER THREAD EXIT"

165165 pure ()

166166

167167startNotificationListener :: NotificationCallback -> IO (ProcessId)

test/Server/Main.hs+2−2

@@ -147,10 +147,10 @@ testNotificationCallback mvar _ _ = putMVar mvar ()

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

148148testNotification mvar sess conn = TestCase $ do

149149 let relvarx = RelationVariable "x"

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

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

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

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

153153 check $ commit sess conn

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

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

155155 check $ commit sess conn

156156 takeMVar mvar

test/TutorialD/Interpreter.hs+17−8

@@ -26,6 +26,7 @@ import Data.Time.Clock (UTCTime(..))

2626import Data.Time.Calendar (fromGregorian)

2727import Data.Interval (interval, Interval, Extended(Finite))

2828import Control.Concurrent.STM

29+import Control.Concurrent

2930import qualified STMContainers.Map as STMMap

3031

3132main :: IO ()

@@ -33,7 +34,7 @@ main = do

3334 tcounts <- runTestTT (TestList tests)

3435 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

3536 where

36− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest]

37+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification]

3738 simpleRelTests = [("x:=true", Right relationTrue),

3839 ("x:=false", Right relationFalse),

3940 ("x:=true union false", Right relationTrue),

@@ -128,14 +129,14 @@ assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interp

128129

129130transactionGraphBasicTest :: Test

130131transactionGraphBasicTest = TestCase $ do

131− (_, dbconn) <- dateExamplesConnection

132+ (_, dbconn) <- dateExamplesConnection emptyNotificationCallback

132133 graph <- transactionGraph dbconn

133134 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing

134135

135136--add a new transaction to the graph, validate it is in the graph

136137transactionGraphAddCommitTest :: Test

137138transactionGraphAddCommitTest = TestCase $ do

138− (sessionId, dbconn) <- dateExamplesConnection

139+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

139140 case parseTutorialD "x:=S" of

140141 Left err -> assertFailure (show err)

141142 Right parsed -> do

@@ -152,7 +153,7 @@ transactionGraphAddCommitTest = TestCase $ do

152153

153154transactionRollbackTest :: Test

154155transactionRollbackTest = TestCase $ do

155− (sessionId, dbconn) <- dateExamplesConnection

156+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

156157 graph <- transactionGraph dbconn

157158 maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "S"))

158159 case maybeErr of

@@ -167,7 +168,7 @@ transactionRollbackTest = TestCase $ do

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

168169transactionJumpTest :: Test

169170transactionJumpTest = TestCase $ do

170− (sessionId, dbconn) <- dateExamplesConnection

171+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

171172 (DisconnectedTransaction firstUUID _) <- disconnectedTransaction sessionId dbconn

172173 maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "S"))

173174 case maybeErr of

@@ -190,7 +191,7 @@ maybeFail Nothing = return ()

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

191192transactionBranchTest :: Test

192193transactionBranchTest = TestCase $ do

193− (sessionId, dbconn) <- dateExamplesConnection

194+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

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

195196 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "S")),

196197 commit sessionId dbconn,

@@ -263,5 +264,13 @@ dateExamplesConnection callback = do

263264testNotification :: Test

264265testNotification = TestCase $ do

265266 notifmvar <- newEmptyMVar

266− let notifCallback mvar = putMVar mvar ()

267− conn <- dateExamplesConnection

267+ let notifCallback mvar = \_ _ -> putMVar mvar ()

268+ relvarx = RelationVariable "x"

269+ (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)

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

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

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

273+ check' $ commit sess conn

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

275+ check' $ commit sess conn

276+ takeMVar notifmvar