git.iko.soy/distributed-process
on master help sign in
test sendChan
6b1362dTim Watson
distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+53−10
compare with master
unifiedsplit
@@ -17,6 +17,7 @@ import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe
17 , nsend
17 , nsend
18 , nsendRemote
18 , nsendRemote
19 , usend
19 , usend
20+ , sendChan
20 )
21 )
21import Control.Distributed.Process.Management
22import Control.Distributed.Process.Management
22 ( MxEvent(..)
23 ( MxEvent(..)
@@ -38,7 +39,7 @@ import Control.Monad.Catch(finally, bracket, try)
38import Control.Rematch (equalTo)
39import Control.Rematch (equalTo)
39import Data.Binary
40import Data.Binary
40import Data.List (find, sort, intercalate)
41import Data.List (find, sort, intercalate)
41−import Data.Maybe (isJust, fromJust, isNothing)
42+import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)
42import Data.Typeable
43import Data.Typeable
43import GHC.Generics hiding (from)
44import GHC.Generics hiding (from)
44#if ! MIN_VERSION_base(4,6,0)
45#if ! MIN_VERSION_base(4,6,0)
@@ -373,15 +374,47 @@ testSend op n r = testMxSend n r $ \p1 sink -> do
373 | pidTo == p1 && pidFrom == us -> return True
374 | pidTo == p1 && pidFrom == us -> return True
374 _ -> return False
375 _ -> return False
375
376
377+testChan :: (SendPort () -> () -> Process ())
378+ -> Maybe LocalNode
379+ -> TestResult Bool
380+ -> Process ()
381+testChan op n r = testMxSend n r $ \p1 sink -> do
382+
383+ us <- getSelfPid
384+ send p1 us
385+
386+ cleared <- receiveChan sink
387+ case cleared of
388+ (MxSent pidTo pidFrom _)
389+ | pidTo == p1 && pidFrom == us -> return ()
390+ _ -> die "Received uncleared Mx Event"
391+
392+ chan <- receiveTimeout 5000000 [ match return ]
393+ let ch' = fromMaybe (error "No reply chan received") chan
394+
395+ -- initiate a send
396+ op ch' ()
397+
398+ -- verify the management event
399+ sent <- receiveChanTimeout 5000000 sink
400+ case sent of
401+ Just (MxSentToPort sId spId _)
402+ | sId == us && spId == sendPortId ch' -> return True
403+ _ -> return False
404+
376type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool
405type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool
377
406
378testMxSend :: Maybe LocalNode -> TestResult Bool -> SendTest -> Process ()
407testMxSend :: Maybe LocalNode -> TestResult Bool -> SendTest -> Process ()
379testMxSend mNode result test = do
408testMxSend mNode result test = do
380 us <- getSelfPid
409 us <- getSelfPid
410+ (sp, rp) <- newChan
381 (chan, sink) <- newChan
411 (chan, sink) <- newChan
382 agent <- mxAgent (MxAgentId $ agentLabel us) () [
412 agent <- mxAgent (MxAgentId $ agentLabel us) () [
383 mxSink $ \ev -> do
413 mxSink $ \ev -> do
384 case ev of
414 case ev of
415+ m@(MxSentToPort _ cid _)
416+ | cid /= sendPortId chan
417+ && cid /= sendPortId sp -> liftMX $ sendChan chan m
385 m@(MxSent _ fromPid _)
418 m@(MxSent _ fromPid _)
386 | fromPid == us -> liftMX $ sendChan chan m
419 | fromPid == us -> liftMX $ sendChan chan m
387 m@(MxSentToName _ fromPid _)
420 m@(MxSentToName _ fromPid _)
@@ -392,7 +425,6 @@ testMxSend mNode result test = do
392 mxReady
425 mxReady
393 ]
426 ]
394
427
395− (sp, rp) <- newChan
396 case mNode of
428 case mNode of
397 Nothing -> void $ spawnLocal (proc sp)
429 Nothing -> void $ spawnLocal (proc sp)
398 Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp
430 Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp
@@ -408,7 +440,16 @@ testMxSend mNode result test = do
408 where
440 where
409 label = "testMxSend"
441 label = "testMxSend"
410 agentLabel s = "mx-unsafe-check-agent-" ++ show s
442 agentLabel s = "mx-unsafe-check-agent-" ++ show s
411− proc sp' = getSelfPid >>= sendChan sp' >> expect :: Process ()
443+ proc sp' = getSelfPid >>= sendChan sp' >> go Nothing
444+
445+ go :: Maybe (ReceivePort ()) -> Process ()
446+ go Nothing = receiveTimeout 5000000 [ match replyChannel ] >>= go
447+ go c@(Just c') = receiveWait [ matchChan c' return ] >> go c
448+
449+ replyChannel p' = do
450+ (s, r) <- newChan
451+ send p' s
452+ return r
412
453
413tests :: TestTransport -> IO [Test]
454tests :: TestTransport -> IO [Test]
414tests TestTransport{..} = do
455tests TestTransport{..} = do
@@ -455,16 +496,18 @@ tests TestTransport{..} = do
455 buildTestCases n1 n2 =
496 buildTestCases n1 n2 =
456 let nid = localNodeId n2 in build n2 [
497 let nid = localNodeId n2 in build n2 [
457 ("NSend", [
498 ("NSend", [
458− ("Unsafe.nsend", testNSend Unsafe.nsend)
459− , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))
460− , ("nsend", testNSend nsend)
499+ ("nsend", testNSend nsend)
500+ , ("Unsafe.nsend", testNSend Unsafe.nsend)
461 , ("nsendRemote", testNSend (nsendRemote nid))
501 , ("nsendRemote", testNSend (nsendRemote nid))
502+ , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))
462 ])
503 ])
463 , ("Send", [
504 , ("Send", [
505+ ("send", testSend send)
464− ("Unsafe.send", testSend Unsafe.send)
506+ , ("Unsafe.send", testSend Unsafe.send)
465− , ("Unsafe.usend", testSend Unsafe.usend)
507+ , ("usend", testSend usend)
466− , ("send", testSend send)
508+ , ("Unsafe.usend", testSend Unsafe.usend)
467− , ("usend", testSend usend)
509+ , ("sendChan", testChan sendChan)
510+ , ("Unsafe.sendChan", testChan Unsafe.sendChan)
468 ])
511 ])
469 , ("Forward", [
512 , ("Forward", [
470 ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))
513 ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))