{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
{-# 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.Closure
import Control.Distributed.Process.Node

import Control.Monad
import Text.Printf
import Data.Binary
import Data.Typeable

import Test.HUnit (Assertion, (@?=))
import Test.Framework (Test, defaultMain)
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
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)
      , (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
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
      [ (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
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
      [ (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
expect = 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
expect, String
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expect)
         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
expect

  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
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 ()
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
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 ()
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
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 ()
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 ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
..} = 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) ]