{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}

-- | XXX test doesn't work, because failure exceptions don't get propagated. The
-- test always claims to succeed, even if it failed.

module Control.Distributed.Process.Tests.Receive (tests) where

import Network.Transport.Test (TestTransport(..))

import Network.Transport (Transport)
import Control.Distributed.Process
import Control.Distributed.Process.Node

import Control.Monad

import Test.HUnit (Assertion, (@?=))
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)

-- Tests:

-- 1. 2 matchChans, receive on each one
-- 2. matchChan/matchIf, receive on each one
-- 3. matchIf/matchChan, receive on each one
-- 4. matchIf/matchChan/matchIf, receive on each one

recTest1 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest1 :: ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest1 ReceivePort ()
wait SendPort String
sync ReceivePort String
r1 ReceivePort String
r2 = do
  Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
    ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
wait
    String
r <- [Match String] -> Process String
forall b. [Match b] -> Process b
receiveWait
      [ ReceivePort String -> (String -> Process String) -> Match String
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort String
r1       ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      , ReceivePort String -> (String -> Process String) -> Match String
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort String
r2       ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received2 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      ]
    SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
sync String
r

recTest2 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest2 :: ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest2 ReceivePort ()
wait SendPort String
sync ReceivePort String
r1 ReceivePort String
_ = do
  Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
    ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
wait
    String
r <- [Match String] -> Process String
forall b. [Match b] -> Process b
receiveWait
      [ ReceivePort String -> (String -> Process String) -> Match String
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort String
r1       ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      , (String -> Bool) -> (String -> Process String) -> Match String
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"foo") ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received2 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      ]
    SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
sync String
r

recTest3 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest3 :: ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest3 ReceivePort ()
wait SendPort String
sync ReceivePort String
r1 ReceivePort String
_ = do
  Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
    ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
wait
    String
r <- [Match String] -> Process String
forall b. [Match b] -> Process b
receiveWait
      [ (String -> Bool) -> (String -> Process String) -> Match String
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"foo") ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      , ReceivePort String -> (String -> Process String) -> Match String
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort String
r1       ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received2 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      ]
    SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
sync String
r

recTest4 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest4 :: ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest4 ReceivePort ()
wait SendPort String
sync ReceivePort String
r1 ReceivePort String
_ = do
  Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
    ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
wait
    String
r <- [Match String] -> Process String
forall b. [Match b] -> Process b
receiveWait
      [ (String -> Bool) -> (String -> Process String) -> Match String
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"foo") ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      , ReceivePort String -> (String -> Process String) -> Match String
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort String
r1       ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received2 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      , (String -> Bool) -> (String -> Process String) -> Match String
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"bar") ((String -> Process String) -> Match String)
-> (String -> Process String) -> Match String
forall a b. (a -> b) -> a -> b
$ \String
s -> String -> Process String
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"received3 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
      ]
    SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
sync String
r

master :: Process ()
master :: Process ()
master = do
  (SendPort ()
waits,ReceivePort ()
waitr) <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  (SendPort String
syncs,ReceivePort String
syncr) <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  let go :: String -> Process ()
go String
expected = do
         SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort ()
waits ()
         String
r <- ReceivePort String -> Process String
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort String
syncr
         IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ (String, String, Bool) -> IO ()
forall a. Show a => a -> IO ()
print (String
r, String
expected, String
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expected)
         IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ String
r String -> String -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= String
expected

  IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"---- Test 1 ----"
  (SendPort String
s1,ReceivePort String
r1) <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  (SendPort String
s2,ReceivePort String
r2) <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  ProcessId
p <- Process () -> Process ProcessId
spawnLocal (ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest1 ReceivePort ()
waitr SendPort String
syncs ReceivePort String
r1 ReceivePort String
r2)

  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1 String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 a"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s2 String
"b" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received2 b"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1 String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s2 String
"b" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  String -> Process ()
go String
"received1 a"
  String -> Process ()
go String
"received2 b"

  ProcessId -> String -> Process ()
kill ProcessId
p String
"BANG"

  IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"\n---- Test 2 ----"
  (SendPort String
s1',ReceivePort String
r1') <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  (SendPort String
_  ,ReceivePort String
r2') <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  ProcessId
p' <- Process () -> Process ProcessId
spawnLocal (ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest2 ReceivePort ()
waitr SendPort String
syncs ReceivePort String
r1' ReceivePort String
r2')

  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 a"
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p' String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received2 foo"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 a"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p String
"bar" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 a"
  String -> Process ()
go String
"received2 foo"

  ProcessId -> String -> Process ()
kill ProcessId
p' String
"BANG"

  IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"\n---- Test 3 ----"
  (SendPort String
s1'',ReceivePort String
r1'') <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  (SendPort String
_   ,ReceivePort String
r2'') <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  ProcessId
p'' <- Process () -> Process ProcessId
spawnLocal (ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest3 ReceivePort ()
waitr SendPort String
syncs ReceivePort String
r1'' ReceivePort String
r2'')

  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1'' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received2 a"
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p'' String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 foo"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1'' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 foo"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1'' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p String
"bar" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received2 a"
  String -> Process ()
go String
"received2 a"

  ProcessId -> String -> Process ()
kill ProcessId
p'' String
"BANG"

  IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"\n---- Test 4 ----"
  (SendPort String
s1''',ReceivePort String
r1''') <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  (SendPort String
_    ,ReceivePort String
r2''') <- Process (SendPort String, ReceivePort String)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  ProcessId
p''' <- Process () -> Process ProcessId
spawnLocal (ReceivePort ()
-> SendPort String
-> ReceivePort String
-> ReceivePort String
-> Process ()
recTest4 ReceivePort ()
waitr SendPort String
syncs ReceivePort String
r1''' ReceivePort String
r2''')

  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1''' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received2 a"
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p''' String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 foo"
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p''' String
"bar" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received3 bar"
  SendPort String -> String -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort String
s1''' String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p''' String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 foo"
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p''' String
"bar" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received2 a"
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p''' String
"foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received1 foo" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
go String
"received3 bar"

  ProcessId -> String -> Process ()
kill ProcessId
p''' String
"BANG"

  Process ()
forall a. Process a
terminate

testReceive :: Transport -> RemoteTable -> Assertion
testReceive :: Transport -> RemoteTable -> IO ()
testReceive Transport
transport RemoteTable
rtable = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
transport RemoteTable
rtable
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ Process ()
master

tests :: TestTransport -> IO [Test]
tests :: TestTransport -> IO [Test]
tests TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
..} = do
    let rtable :: RemoteTable
rtable = RemoteTable
initRemoteTable
    [Test] -> IO [Test]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ String -> IO () -> Test
testCase String
"testReceive" (Transport -> RemoteTable -> IO ()
testReceive Transport
testTransport RemoteTable
rtable) ]