git.iko.soy/distributed-process
on master help sign in
Ensure that unmask operates on the correct (scoped) LocalProcess
78192d1Tim Watson
distributed-process.cabal+2−1
compare with master
unifiedsplit
@@ -102,7 +102,8 @@ Test-Suite TestCH
102 network >= 2.3 && < 2.5,
102 network >= 2.3 && < 2.5,
103 HUnit >= 1.2 && < 1.3,
103 HUnit >= 1.2 && < 1.3,
104 test-framework >= 0.6 && < 0.9,
104 test-framework >= 0.6 && < 0.9,
105− test-framework-hunit >= 0.2.0 && < 0.4
105+ test-framework-hunit >= 0.2.0 && < 0.4,
106+ rematch >= 0.1.2.1
106 Extensions: CPP,
107 Extensions: CPP,
107 ScopedTypeVariables,
108 ScopedTypeVariables,
108 DeriveDataTypeable,
109 DeriveDataTypeable,
src/Control/Distributed/Process/Internal/Primitives.hs+6−3
@@ -716,10 +716,13 @@ mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b
716mask p = do
716mask p = do
717 lproc <- ask
717 lproc <- ask
718 liftIO $ Ex.mask $ \restore ->
718 liftIO $ Ex.mask $ \restore ->
719− runLocalProcess lproc (p (liftRestore lproc restore))
719+ runLocalProcess lproc (p (liftRestore restore))
720 where
720 where
721− liftRestore :: LocalProcess -> (forall a. IO a -> IO a) -> (forall a. Process a -> Process a)
721+ liftRestore :: (forall a. IO a -> IO a)
722+ -> (forall a. Process a -> Process a)
723+ liftRestore restoreIO = \p2 -> do
724+ ourLocalProc <- ask
722− liftRestore lproc restoreIO = liftIO . restoreIO . runLocalProcess lproc
725+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2
723
726
724-- | Lift 'Control.Exception.onException'
727-- | Lift 'Control.Exception.onException'
725onException :: Process a -> Process b -> Process a
728onException :: Process a -> Process b -> Process a
tests/TestCH.hs+18−1
@@ -15,7 +15,7 @@ import Control.Concurrent.MVar
15 , takeMVar
15 , takeMVar
16 , readMVar
16 , readMVar
17 )
17 )
18−import Control.Monad (replicateM_, replicateM, forever)
18+import Control.Monad (replicateM_, replicateM, forever, void)
19import Control.Exception (SomeException, throwIO)
19import Control.Exception (SomeException, throwIO)
20import qualified Control.Exception as Ex (catch)
20import qualified Control.Exception as Ex (catch)
21import Control.Applicative ((<$>), (<*>), pure, (<|>))
21import Control.Applicative ((<$>), (<*>), pure, (<|>))
@@ -39,6 +39,8 @@ import Control.Distributed.Process.Serializable (Serializable)
39import Test.HUnit (Assertion)
39import Test.HUnit (Assertion)
40import Test.Framework (Test, defaultMain, testGroup)
40import Test.Framework (Test, defaultMain, testGroup)
41import Test.Framework.Providers.HUnit (testCase)
41import Test.Framework.Providers.HUnit (testCase)
42+import Control.Rematch hiding (expect, match)
43+import qualified Control.Rematch as Rematch (expect)
42
44
43newtype Ping = Ping ProcessId
45newtype Ping = Ping ProcessId
44 deriving (Typeable, Binary, Show)
46 deriving (Typeable, Binary, Show)
@@ -1074,6 +1076,20 @@ testCatches transport = do
1074
1076
1075 takeMVar done
1077 takeMVar done
1076
1078
1079+testMaskRestoreScope :: NT.Transport -> Assertion
1080+testMaskRestoreScope transport = do
1081+ localNode <- newLocalNode transport initRemoteTable
1082+ parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1083+ spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1084+
1085+ void $ runProcess localNode $ mask $ \unmask -> do
1086+ getSelfPid >>= liftIO . putMVar parentPid
1087+ void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1088+
1089+ parent <- liftIO $ takeMVar parentPid
1090+ child <- liftIO $ takeMVar spawnedPid
1091+ Rematch.expect parent $ isNot $ equalTo child
1092+
1077testDie :: NT.Transport -> Assertion
1093testDie :: NT.Transport -> Assertion
1078testDie transport = do
1094testDie transport = do
1079 localNode <- newLocalNode transport initRemoteTable
1095 localNode <- newLocalNode transport initRemoteTable
@@ -1178,6 +1194,7 @@ tests (transport, transportInternals) = [
1178 , testCase "PrettyExit" (testPrettyExit transport)
1194 , testCase "PrettyExit" (testPrettyExit transport)
1179 , testCase "CatchesExit" (testCatchesExit transport)
1195 , testCase "CatchesExit" (testCatchesExit transport)
1180 , testCase "Catches" (testCatches transport)
1196 , testCase "Catches" (testCatches transport)
1197+ , testCase "MaskRestoreScope" (testMaskRestoreScope transport)
1181 , testCase "ExitLocal" (testExitLocal transport)
1198 , testCase "ExitLocal" (testExitLocal transport)
1182 , testCase "ExitRemote" (testExitRemote transport)
1199 , testCase "ExitRemote" (testExitRemote transport)
1183 ]
1200 ]