git.iko.soy/distributed-process
on master help sign in
fix laziness bug in the Binary instance for ProcessInfo, add some more

test cases

commit9e3786b4baeb84afe016f4e70072b4abe762e82e authorTim Watson <tim@rabbitmq.com> dateThu 20 Dec 2012, 14:26 (14 years ago) parentc094e66
5 files changed+112−34
compare with master
unifiedsplit
distributed-process/distributed-process.cabal+1 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+4−3 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+9−9 distributed-process/src/Control/Distributed/Process/Node.hs+43−19 distributed-process/tests/TestStats.hs+55−3
distributed-process/distributed-process.cabal+1
@@ -131,6 +131,7 @@ Test-Suite TestStats
131131 Build-Depends: base >= 4.4 && < 5,
132132 random >= 1.0 && < 1.1,
133133 ansi-terminal >= 0.5 && < 0.6,
134+ containers >= 0.4 && < 0.6,
134135 distributed-process,
135136 network-transport >= 0.3 && < 0.4,
136137 network-transport-tcp >= 0.3 && < 0.4,
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+4−3
@@ -415,10 +415,11 @@ getProcessInfo pid =
415415 liftIO . putStrLn $ "sending getInfo req to " ++ (show dest)
416416
417417 sendCtrlMsg dest $ GetInfo pid
418+ liftIO . putStrLn $ "waiting for response"
418419 receiveWait [
419− match (\x@(ProcessInfo _ _ _ _ _) -> return (Just x))
420− , match (\(ProcessInfoNone _) -> return Nothing)
421− ]
420+ match (\(p :: ProcessInfo) -> return $ Just p)
421+ , match (\(n :: ProcessInfoNone) -> return Nothing)
422+ ]
422423 where mkNode :: NodeId -> NodeId -> Process (Maybe NodeId)
423424 mkNode them us = case them == us of
424425 True -> return Nothing
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+9−9
@@ -461,25 +461,25 @@ toPInfoKey (SerializedProcessInfoKey n)
461461 | n == 4 = ProcessInfoMessageQueueLength
462462 | n == 5 = ProcessInfoMonitors
463463 | n == 6 = ProcessInfoLinks
464− -- using error is usually madness, but here represents a bit of complete
465− -- stupidity or a deliberate attack, so how *should* we handle this?
464+ -- using error is usually madness, but here represents either a silly mistake
465+ -- or a deliberate attack, because only *we* actually construct these!
466466 | otherwise = error "Illegal ProcessInfoKey Value"
467467
468468data ProcessInfo = ProcessInfo {
469469 infoNode :: NodeId
470470 , infoRegisteredNames :: [String]
471471 , infoMessageQueueLength :: Maybe Int
472− , infoMonitors :: Set (ProcessId, MonitorRef)
473− , infoLinks :: Set ProcessId
472+ , infoMonitors :: [(ProcessId, MonitorRef)]
473+ , infoLinks :: [ProcessId]
474474 } deriving (Show, Eq, Typeable)
475475
476476instance Binary ProcessInfo where
477477 get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
478− put = put . infoNode
479− >> put . infoRegisteredNames
480− >> put . infoMessageQueueLength
481− >> put . infoMonitors
482− >> put . infoLinks
478+ put pInfo = put (infoNode pInfo)
479+ >> put (infoRegisteredNames pInfo)
480+ >> put (infoMessageQueueLength pInfo)
481+ >> put (infoMonitors pInfo)
482+ >> put (infoLinks pInfo)
483483
484484data ProcessInfoNone = ProcessInfoNone DiedReason
485485 deriving (Show, Typeable)
distributed-process/src/Control/Distributed/Process/Node.hs+43−19
@@ -33,7 +33,14 @@ import qualified Data.Map as Map
3333 , keys
3434 )
3535import Data.Set (Set)
36−import qualified Data.Set as Set (empty, insert, delete, member, foldl')
36+import qualified Data.Set as Set
37+ ( empty
38+ , insert
39+ , delete
40+ , member
41+ , foldl'
42+ , toList
43+ )
3744import Data.Foldable (forM_)
3845import Data.Maybe (isJust, isNothing, catMaybes)
3946import Data.Typeable (Typeable)
@@ -756,43 +763,54 @@ ncEffectGetInfo from pid =
756763 node <- ask
757764 mProc <- liftIO $ withMVar (localState node) $ return . (^. localProcessWithId lpid)
758765 case mProc of
759− Nothing -> do
760− dispatch (isLocal node (ProcessIdentifier from))
761− from node (ProcessInfoNone DiedUnknownId)
766+ Nothing -> dispatch (isLocal node (ProcessIdentifier from))
767+ from node (ProcessInfoNone DiedUnknownId)
762768 Just proc -> do
763− itsLinks <- gets (^. linksFor them)
764− itsMons <- gets (^. monitorsFor them)
765− registered <- gets (^. registeredHere)
766− sendInfo pid
767− (isLocal node (ProcessIdentifier from))
768− proc node itsLinks itsMons (registeredNames registered)
769+ liftIO . putStrLn $ "getting links"
770+ itsLinks <- gets (^. linksFor them)
771+ liftIO . putStrLn $ "getting monitors"
772+ itsMons <- gets (^. monitorsFor them)
773+ liftIO . putStrLn $ "getting registered names"
774+ registered <- gets (^. registeredHere)
775+ sendInfo pid
776+ (isLocal node (ProcessIdentifier from))
777+ proc
778+ node
779+ (Set.toList itsLinks)
780+ (Set.toList itsMons)
781+ (registeredNames registered)
769782
770783 where sendInfo :: ProcessId
771784 -> Bool
772785 -> LocalProcess
773786 -> LocalNode
774− -> Set ProcessId
775− -> Set (ProcessId, MonitorRef)
787+ -> [ProcessId]
788+ -> [(ProcessId, MonitorRef)]
776789 -> [String]
777790 -> NC ()
778− sendInfo d lc lp n l m r = do
791+ sendInfo d lc lp n l m r =
792+ let n' = processNodeId pid
793+ in do
779794 qLen <- qLength lp
780795 dispatch lc d n ProcessInfo {
781− infoNode = localNodeId n
796+ infoNode = n'
782797 , infoRegisteredNames = r
783798 , infoMessageQueueLength = qLen
784799 , infoMonitors = m
785800 , infoLinks = l
786801 }
787802
788− dispatch :: (Serializable a)
803+ dispatch :: (Serializable a, Show a)
789804 => Bool
790805 -> ProcessId
791806 -> LocalNode
792807 -> a
793808 -> NC ()
794− dispatch True dest _ pInfo = postAsMessage dest $ pInfo
795− dispatch False dest node pInfo =
809+ dispatch True dest _ pInfo = do
810+ -- liftIO $ putStrLn $ "posting " ++ (show pInfo) ++ " to " ++ (show dest)
811+ postAsMessage dest $ pInfo
812+ dispatch False dest node pInfo = do
813+ -- liftIO $ putStrLn $ "posting pinfo to node of " ++ (show dest)
796814 liftIO $ sendMessage node
797815 (NodeIdentifier (localNodeId node))
798816 (ProcessIdentifier dest)
@@ -802,10 +820,14 @@ ncEffectGetInfo from pid =
802820 -- TODO: make this available to other functions?
803821 qLength :: LocalProcess -> NC (Maybe Int)
804822 qLength lp = do
823+ liftIO $ putStrLn "getting qLen"
805824 qRef <- liftIO $ deRefWeak (processWeakQ lp)
825+ liftIO $ putStrLn "checking length..."
806826 case qRef of
807827 Nothing -> return $ Nothing
808− Just qr -> liftIO $ Mailbox.length qr >>= return . Just
828+ Just q -> do
829+ len <- liftIO $ Mailbox.length q
830+ return $ Just len
809831
810832 registeredNames = Map.foldlWithKey (\ks k v -> if v == pid
811833 then (k:ks)
@@ -902,7 +924,9 @@ postAsMessage :: Serializable a => ProcessId -> a -> NC ()
902924postAsMessage pid = postMessage pid . createMessage
903925
904926postMessage :: ProcessId -> Message -> NC ()
905−postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg
927+postMessage pid msg = do
928+ liftIO $ putStrLn ("posting message to " ++ show pid)
929+ withLocalProc pid $ \p -> enqueue (processQueue p) msg
906930
907931throwException :: Exception e => ProcessId -> e -> NC ()
908932throwException pid e = withLocalProc pid $ \p ->
distributed-process/tests/TestStats.hs+55−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
23module Main where
34
@@ -10,6 +11,7 @@ import Test.Framework
1011 )
1112import Network.Transport.TCP
1213import Control.Distributed.Process
14+import Control.Distributed.Process.Internal.Types ( MonitorRef(..) )
1315import Control.Distributed.Process.Node
1416 ( forkProcess
1517 , newLocalNode
@@ -22,6 +24,9 @@ import Control.Concurrent.MVar
2224 , putMVar
2325 , takeMVar
2426 )
27+import qualified Data.Set as Set
28+import Data.Binary
29+import Data.Typeable()
2530import Test.HUnit (Assertion)
2631import Test.HUnit.Base (assertBool)
2732import Test.Framework.Providers.HUnit (testCase)
@@ -62,14 +67,61 @@ testLocalDeadProcessInfo result = do
6267 say "waiting for process info...."
6368 getProcessInfo pid >>= stash result
6469
70+testLocalLiveProcessInfo :: TestResult Bool -> Process ()
71+testLocalLiveProcessInfo result = do
72+ self <- getSelfPid
73+ node <- getSelfNode
74+ register "foobar" self
75+
76+ mon <- liftIO $ newEmptyMVar
77+ mapM (send self) ["hello", "there", "mr", "process"]
78+ pid <- spawnLocal $ do
79+ me <- getSelfPid
80+ link self
81+ mRef <- monitor self
82+ stash mon mRef
83+ "die" <- expect
84+ return ()
85+
86+ monRef <- liftIO $ takeMVar mon
87+
88+ xlog ("grabbing process-info for " ++ (show self))
89+ mpInfo <- getProcessInfo self
90+
91+ xlog "checking pInfo"
92+ case Just mpInfo of
93+ Nothing -> stash result False
94+ Just _ -> stash result True
95+ -- where verifyPInfo :: ProcessInfo
96+ -- -> ProcessId
97+ -- -> MonitorRef
98+ -- -> NodeId
99+ -- -> Process ()
100+ -- verifyPInfo pInfo pid mref node =
101+ -- stash result $ infoNode pInfo == node &&
102+ -- verifyLinks pInfo == [pid] &&
103+ -- verifyMonitors pInfo == [(pid, mref)] &&
104+ -- infoMessageQueueLength pInfo == Just 4 &&
105+ -- infoRegisteredNames pInfo == ["foobar"]
106+ -- verifyLinks = Set.toList . infoLinks
107+ -- verifyMonitors = Set.toList . infoMonitors
108+
109+xlog :: String -> Process ()
110+xlog s = liftIO $ putStrLn s
111+
65112tests :: LocalNode -> IO [Test]
66113tests node1 = do
67114 return [
68115 testGroup "Process Info" [
69− testCase "testLocalDeadProcessInfo"
116+ -- testCase "testLocalDeadProcessInfo"
117+ -- (delayedAssertion
118+ -- "expected dead process-info to be ProcessInfoNone"
119+ -- node1 (Nothing) testLocalDeadProcessInfo)
120+ -- ,
121+ testCase "testLocalLiveProcessInfo"
70122 (delayedAssertion
71− "expected dead process-info to be ProcessInfoNone"
72− node1 (Nothing) testLocalDeadProcessInfo)
123+ "expected process-info to be correctly populated"
124+ node1 True testLocalLiveProcessInfo)
73125 ] ]
74126
75127mkNode :: String -> IO LocalNode