git.iko.soy/distributed-process
on master help sign in
Ensure that unmask operates on the correct (scoped) LocalProcess

Previously the LocalProcess from the outer (masked) scope was passed to runLocalProcess, which could lead to catastrophic changes in runtime behaviour, e.g., receiving (esp. on typed channels) blocking indefinitely since the the caller would be referring to someone else's mailbox. Reported by Jeff Epstein, Facundo Dominguez. Fixes pull requests #138 and #139.

commit78192d185227d5c167eb47519404529759eeb4c3 authorTim Watson <tim@rabbitmq.com> dateThu 9 May 2013, 11:05 (13 years ago) parent7e5163d878446a
3 files changed+26−5
compare with master
unifiedsplit
distributed-process.cabal+2−1 src/Control/Distributed/Process/Internal/Primitives.hs+6−3 tests/TestCH.hs+18−1
distributed-process.cabal+2−1
@@ -102,7 +102,8 @@ Test-Suite TestCH
102102 network >= 2.3 && < 2.5,
103103 HUnit >= 1.2 && < 1.3,
104104 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
106107 Extensions: CPP,
107108 ScopedTypeVariables,
108109 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
716716mask p = do
717717 lproc <- ask
718718 liftIO $ Ex.mask $ \restore ->
719− runLocalProcess lproc (p (liftRestore lproc restore))
719+ runLocalProcess lproc (p (liftRestore restore))
720720 where
721− liftRestore :: LocalProcess -> (forall a. IO a -> IO a) -> (forall a. Process a -> Process a)
722− liftRestore lproc restoreIO = liftIO . restoreIO . runLocalProcess lproc
721+ liftRestore :: (forall a. IO a -> IO a)
722+ -> (forall a. Process a -> Process a)
723+ liftRestore restoreIO = \p2 -> do
724+ ourLocalProc <- ask
725+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2
723726
724727-- | Lift 'Control.Exception.onException'
725728onException :: Process a -> Process b -> Process a
tests/TestCH.hs+18−1
@@ -15,7 +15,7 @@ import Control.Concurrent.MVar
1515 , takeMVar
1616 , readMVar
1717 )
18−import Control.Monad (replicateM_, replicateM, forever)
18+import Control.Monad (replicateM_, replicateM, forever, void)
1919import Control.Exception (SomeException, throwIO)
2020import qualified Control.Exception as Ex (catch)
2121import Control.Applicative ((<$>), (<*>), pure, (<|>))
@@ -39,6 +39,8 @@ import Control.Distributed.Process.Serializable (Serializable)
3939import Test.HUnit (Assertion)
4040import Test.Framework (Test, defaultMain, testGroup)
4141import Test.Framework.Providers.HUnit (testCase)
42+import Control.Rematch hiding (expect, match)
43+import qualified Control.Rematch as Rematch (expect)
4244
4345newtype Ping = Ping ProcessId
4446 deriving (Typeable, Binary, Show)
@@ -1074,6 +1076,20 @@ testCatches transport = do
10741076
10751077 takeMVar done
10761078
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+
10771093testDie :: NT.Transport -> Assertion
10781094testDie transport = do
10791095 localNode <- newLocalNode transport initRemoteTable
@@ -1178,6 +1194,7 @@ tests (transport, transportInternals) = [
11781194 , testCase "PrettyExit" (testPrettyExit transport)
11791195 , testCase "CatchesExit" (testCatchesExit transport)
11801196 , testCase "Catches" (testCatches transport)
1197+ , testCase "MaskRestoreScope" (testMaskRestoreScope transport)
11811198 , testCase "ExitLocal" (testExitLocal transport)
11821199 , testCase "ExitRemote" (testExitRemote transport)
11831200 ]