c094e66 · distributed-process

git.iko.soy/distributed-process

add test case for (getProcessInfo deadPid) == ProcessInfoNone

commitc094e6679d317484832b8d86039b774204a96799 authorTim Watson <tim@rabbitmq.com> dateMon 17 Dec 2012, 16:46 (14 years ago) parentf457c12

6 files changed+131−9

compare with master

unifiedsplit

distributed-process/distributed-process.cabal+22 distributed-process/src/Control/Distributed/Process.hs+4 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+6−3 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3 distributed-process/src/Control/Distributed/Process/Node.hs+8−3 distributed-process/tests/TestStats.hs+88

distributed-process/distributed-process.cabal+22

@@ -123,8 +123,30 @@ Test-Suite TestClosure

123123 Extensions: CPP,

124124 ScopedTypeVariables

125125 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

126+ HS-Source-Dirs: tests

127+

128+Test-Suite TestStats

129+ Type: exitcode-stdio-1.0

130+ Main-Is: TestStats.hs

131+ Build-Depends: base >= 4.4 && < 5,

132+ random >= 1.0 && < 1.1,

133+ ansi-terminal >= 0.5 && < 0.6,

134+ distributed-process,

135+ network-transport >= 0.3 && < 0.4,

136+ network-transport-tcp >= 0.3 && < 0.4,

137+ binary >= 0.5 && < 0.7,

138+ network >= 2.3 && < 2.5,

139+ HUnit >= 1.2 && < 1.3,

140+ test-framework >= 0.6 && < 0.7,

141+ test-framework-hunit >= 0.2 && < 0.3

142+ Extensions: CPP,

143+ ScopedTypeVariables,

144+ DeriveDataTypeable,

145+ GeneralizedNewtypeDeriving

146+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

126147 HS-Source-Dirs: tests

127148

149+

128150Executable distributed-process-throughput

129151 if flag(benchmarks)

130152 Build-Depends: base >= 4.4 && < 5,

distributed-process/src/Control/Distributed/Process.hs+4

@@ -52,6 +52,8 @@ module Control.Distributed.Process

5252 , SpawnRef

5353 , getSelfPid

5454 , getSelfNode

55+ , ProcessInfo(..)

56+ , getProcessInfo

5557 -- * Monitoring and linking

5658 , link

5759 , linkNode

@@ -199,6 +201,8 @@ import Control.Distributed.Process.Internal.Primitives

199201 , kill

200202 , getSelfPid

201203 , getSelfNode

204+ , ProcessInfo(..)

205+ , getProcessInfo

202206 -- Monitoring and linking

203207 , link

204208 , linkNode

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+6−3

@@ -86,6 +86,7 @@ import Prelude hiding (catch)

8686import Data.Binary (decode)

8787import Data.Time.Clock (getCurrentTime)

8888import Data.Time.Format (formatTime)

89+import System.IO (hPutStrLn, stderr)

8990import System.Locale (defaultTimeLocale)

9091import System.Timeout (timeout)

9192import Control.Monad (when)

@@ -407,14 +408,16 @@ getSelfNode = localNodeId . processNode <$> ask

407408

408409-- | Get information about the specified process

409410getProcessInfo :: ProcessId -> Process (Maybe ProcessInfo)

410−getProcessInfo pid =

411+getProcessInfo pid =

411412 let them = processNodeId pid in do

412413 us <- getSelfNode

413414 dest <- mkNode them us

415+ liftIO . putStrLn $ "sending getInfo req to " ++ (show dest)

416+

414417 sendCtrlMsg dest $ GetInfo pid

415418 receiveWait [

416419 match (\x@(ProcessInfo _ _ _ _ _) -> return (Just x))

417− , match (\(ProcessInfoNone _) -> return Nothing)

420+ , match (\(ProcessInfoNone _) -> return Nothing)

418421 ]

419422 where mkNode :: NodeId -> NodeId -> Process (Maybe NodeId)

420423 mkNode them us = case them == us of

@@ -540,7 +543,7 @@ try p = do

540543 lproc <- ask

541544 liftIO $ Ex.try (runLocalProcess lproc p)

542545

543−-- | Lift 'Control.Exception.mask'

546+-- | Lift 'Control.Exception.mask'

544547mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

545548mask p = do

546549 lproc <- ask

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3

@@ -452,7 +452,7 @@ toMarshalledPInfoKey ProcessInfoMessageQueueLength = SerializedProcessInfoKey 4

452452toMarshalledPInfoKey ProcessInfoMonitors = SerializedProcessInfoKey 5

453453toMarshalledPInfoKey ProcessInfoLinks = SerializedProcessInfoKey 6

454454

455−-- | Convert 'SerializedProcessInfoKey' back into 'ProcessInfoKey'

455+-- | Convert 'SerializedProcessInfoKey' back into 'ProcessInfoKey'

456456toPInfoKey :: SerializedProcessInfoKey -> ProcessInfoKey

457457toPInfoKey (SerializedProcessInfoKey n)

458458 | n == 1 = ProcessInfoAll

@@ -471,7 +471,7 @@ data ProcessInfo = ProcessInfo {

471471 , infoMessageQueueLength :: Maybe Int

472472 , infoMonitors :: Set (ProcessId, MonitorRef)

473473 , infoLinks :: Set ProcessId

474− } deriving (Show, Typeable)

474+ } deriving (Show, Eq, Typeable)

475475

476476instance Binary ProcessInfo where

477477 get = ProcessInfo <$> get <*> get <*> get <*> get <*> get

@@ -486,7 +486,7 @@ data ProcessInfoNone = ProcessInfoNone DiedReason

486486

487487instance Binary ProcessInfoNone where

488488 get = ProcessInfoNone <$> get

489− put (ProcessInfoNone r) = put r

489+ put (ProcessInfoNone r) = put r

490490

491491--------------------------------------------------------------------------------

492492-- Node controller internal data types --

distributed-process/src/Control/Distributed/Process/Node.hs+8−3

@@ -124,6 +124,7 @@ import Control.Distributed.Process.Internal.Types

124124 , Identifier(..)

125125 , nodeOf

126126 , ProcessInfo(..)

127+ , ProcessInfoNone(..)

127128 , SendPortId(..)

128129 , typedChannelWithId

129130 , RegisterReply(..)

@@ -751,10 +752,13 @@ ncEffectGetInfo from pid =

751752 let lpid = processLocalId pid

752753 them = (ProcessIdentifier pid)

753754 in do

755+ liftIO . putStrLn $ "processing get info"

754756 node <- ask

755757 mProc <- liftIO $ withMVar (localState node) $ return . (^. localProcessWithId lpid)

756758 case mProc of

757− Nothing -> return () -- send a response to the caller

759+ Nothing -> do

760+ dispatch (isLocal node (ProcessIdentifier from))

761+ from node (ProcessInfoNone DiedUnknownId)

758762 Just proc -> do

759763 itsLinks <- gets (^. linksFor them)

760764 itsMons <- gets (^. monitorsFor them)

@@ -781,10 +785,11 @@ ncEffectGetInfo from pid =

781785 , infoLinks = l

782786 }

783787

784− dispatch :: Bool

788+ dispatch :: (Serializable a)

789+ => Bool

785790 -> ProcessId

786791 -> LocalNode

787− -> ProcessInfo

792+ -> a

788793 -> NC ()

789794 dispatch True dest _ pInfo = postAsMessage dest $ pInfo

790795 dispatch False dest node pInfo =

distributed-process/tests/TestStats.hsnew file+88

@@ -0,0 +1,88 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+module Main where

4+import Prelude hiding (catch)

5+import qualified Network.Transport as NT

6+import Test.Framework

7+ ( Test

8+ , defaultMain

9+ , testGroup

10+ )

11+import Network.Transport.TCP

12+import Control.Distributed.Process

13+import Control.Distributed.Process.Node

14+ ( forkProcess

15+ , newLocalNode

16+ , initRemoteTable

17+ , closeLocalNode

18+ , LocalNode)

19+import Control.Concurrent.MVar

20+ ( MVar

21+ , newEmptyMVar

22+ , putMVar

23+ , takeMVar

24+ )

25+import Test.HUnit (Assertion)

26+import Test.HUnit.Base (assertBool)

27+import Test.Framework.Providers.HUnit (testCase)

28+

29+-- these utilities have been cribbed from distributed-process-platform

30+-- we should really find a way to share them...

31+

32+-- | A mutable cell containing a test result.

33+type TestResult a = MVar a

34+

35+delayedAssertion :: (Eq a) => String -> LocalNode -> a ->

36+ (TestResult a -> Process ()) -> Assertion

37+delayedAssertion note localNode expected testProc = do

38+ result <- newEmptyMVar

39+ _ <- forkProcess localNode $ testProc result

40+ assertComplete note result expected

41+

42+assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()

43+assertComplete msg mv a = do

44+ b <- takeMVar mv

45+ assertBool msg (a == b)

46+

47+stash :: TestResult a -> a -> Process ()

48+stash mvar x = liftIO $ putMVar mvar x

49+

50+------

51+

52+testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()

53+testLocalDeadProcessInfo result = do

54+ pid <- spawnLocal $ do "finish" <- expect; return ()

55+ mref <- monitor pid

56+ send pid "finish"

57+ _ <- receiveWait [

58+ matchIf (\(ProcessMonitorNotification ref' pid' r) ->

59+ ref' == mref && pid' == pid && r == DiedNormal)

60+ (\p -> return p)

61+ ]

62+ say "waiting for process info...."

63+ getProcessInfo pid >>= stash result

64+

65+tests :: LocalNode -> IO [Test]

66+tests node1 = do

67+ return [

68+ testGroup "Process Info" [

69+ testCase "testLocalDeadProcessInfo"

70+ (delayedAssertion

71+ "expected dead process-info to be ProcessInfoNone"

72+ node1 (Nothing) testLocalDeadProcessInfo)

73+ ] ]

74+

75+mkNode :: String -> IO LocalNode

76+mkNode port = do

77+ Right (transport1, _) <- createTransportExposeInternals

78+ "127.0.0.1" port defaultTCPParameters

79+ newLocalNode transport1 initRemoteTable

80+

81+main :: IO ()

82+main = do

83+ node1 <- mkNode "8081"

84+ testData <- tests node1

85+ defaultMain testData

86+ closeLocalNode node1

87+ return ()

88+