Receive.hs

{-# 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.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, (@?=), 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 wait sync r1 r2 = do
  forever $ do
    receiveChan wait
    r <- receiveWait
      [ matchChan r1       $ \s -> return ("received1 " ++ s)
      , matchChan r2       $ \s -> return ("received2 " ++ s)
      ]
    sendChan sync r

recTest2 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest2 wait sync r1 _ = do
  forever $ do
    receiveChan wait
    r <- receiveWait
      [ matchChan r1       $ \s -> return ("received1 " ++ s)
      , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
      ]
    sendChan sync r

recTest3 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest3 wait sync r1 _ = do
  forever $ do
    receiveChan wait
    r <- receiveWait
      [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
      , matchChan r1       $ \s -> return ("received2 " ++ s)
      ]
    sendChan sync r

recTest4 :: ReceivePort ()
         -> SendPort String
         -> ReceivePort String -> ReceivePort String
         -> Process ()
recTest4 wait sync r1 _ = do
  forever $ do
    receiveChan wait
    r <- receiveWait
      [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
      , matchChan r1       $ \s -> return ("received2 " ++ s)
      , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
      ]
    sendChan sync r

master :: Process ()
master = do
  (waits,waitr) <- newChan
  (syncs,syncr) <- newChan
  let go expected = do
         sendChan waits ()
         r <- receiveChan syncr
         liftIO $ print (r, expected, r == expected)
         liftIO $ r @?= expected

  liftIO $ putStrLn "---- Test 1 ----"
  (s1,r1) <- newChan
  (s2,r2) <- newChan
  p <- spawnLocal (recTest1 waitr syncs r1 r2)

  sendChan s1 "a" >> go "received1 a"
  sendChan s2 "b" >> go "received2 b"
  sendChan s1 "a" >>  sendChan s2 "b" >>  go "received1 a"
  go "received2 b"

  kill p "BANG"

  liftIO $ putStrLn "\n---- Test 2 ----"
  (s1',r1') <- newChan
  (_  ,r2') <- newChan
  p' <- spawnLocal (recTest2 waitr syncs r1' r2')

  sendChan s1' "a" >> go "received1 a"
  send p' "foo" >> go "received2 foo"
  sendChan s1' "a" >> send p "foo" >> go "received1 a"
  sendChan s1' "a" >> send p "bar" >> go "received1 a"
  go "received2 foo"

  kill p' "BANG"

  liftIO $ putStrLn "\n---- Test 3 ----"
  (s1'',r1'') <- newChan
  (_   ,r2'') <- newChan
  p'' <- spawnLocal (recTest3 waitr syncs r1'' r2'')

  sendChan s1'' "a" >> go "received2 a"
  send p'' "foo" >> go "received1 foo"
  sendChan s1'' "a" >> send p "foo" >> go "received1 foo"
  sendChan s1'' "a" >> send p "bar" >> go "received2 a"
  go "received2 a"

  kill p'' "BANG"

  liftIO $ putStrLn "\n---- Test 4 ----"
  (s1''',r1''') <- newChan
  (_    ,r2''') <- newChan
  p''' <- spawnLocal (recTest4 waitr syncs r1''' r2''')

  sendChan s1''' "a" >> go "received2 a"
  send p''' "foo" >> go "received1 foo"
  send p''' "bar" >> go "received3 bar"
  sendChan s1''' "a" >> send p''' "foo" >> go "received1 foo"
  send p''' "bar" >> go "received2 a"
  send p''' "foo" >> go "received1 foo" >> go "received3 bar"

  kill p''' "BANG"

  terminate

testReceive :: Transport -> RemoteTable -> Assertion
testReceive transport rtable = do
  node <- newLocalNode transport rtable
  runProcess node $ master

tests :: TestTransport -> IO TestTree
tests TestTransport{..} = do
    let rtable = initRemoteTable
    return $ testGroup "Receive"
        [ testCase "testReceive" (testReceive testTransport rtable) ]