@@ -757,6 +757,121 @@ testMatchAny transport = do
757757
758758 takeMVar clientDone
759759
760+-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
761+-- in between, however we block 'Divide' requests ....
762+testMatchAnyHandle :: NT.Transport -> Assertion
763+testMatchAnyHandle transport = do
764+ proxyAddr <- newEmptyMVar
765+ clientDone <- newEmptyMVar
766+
767+ -- Math server
768+ forkIO $ do
769+ localNode <- newLocalNode transport initRemoteTable
770+ mathServer <- forkProcess localNode math
771+ proxyServer <- forkProcess localNode $ forever $ do
772+ receiveWait [
773+ matchAny (maybeForward mathServer)
774+ ]
775+ putMVar proxyAddr proxyServer
776+
777+ -- Client
778+ forkIO $ do
779+ localNode <- newLocalNode transport initRemoteTable
780+ mathServer <- readMVar proxyAddr
781+
782+ runProcess localNode $ do
783+ pid <- getSelfPid
784+ send mathServer (Add pid 1 2)
785+ 3 <- expect :: Process Double
786+ send mathServer (Divide pid 8 2)
787+ Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
788+ liftIO $ putMVar clientDone ()
789+
790+ takeMVar clientDone
791+ where maybeForward :: ProcessId -> AbstractMessage -> Process (Maybe ())
792+ maybeForward s msg =
793+ maybeHandleMessage msg (\m@(Add _ _ _) -> send s m)
794+
795+testMatchAnyNoHandle :: NT.Transport -> Assertion
796+testMatchAnyNoHandle transport = do
797+ addr <- newEmptyMVar
798+ clientDone <- newEmptyMVar
799+ serverDone <- newEmptyMVar
800+
801+ -- Math server
802+ forkIO $ do
803+ localNode <- newLocalNode transport initRemoteTable
804+ server <- forkProcess localNode $ forever $ do
805+ receiveWait [
806+ matchAnyIf
807+ -- the condition has type `Add -> Bool`
808+ (\(Add _ _ _) -> True)
809+ -- the match `AbstractMessage -> Process ()` will succeed!
810+ (\m -> do
811+ -- `String -> Process ()` does *not* match the input types however
812+ r <- (maybeHandleMessage m (\(_ :: String) -> die "NONSENSE" ))
813+ case r of
814+ Nothing -> return ()
815+ Just _ -> die "NONSENSE")
816+ ]
817+ -- we *must* have removed the message from our mailbox though!!!
818+ Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
819+ liftIO $ putMVar serverDone ()
820+ putMVar addr server
821+
822+ -- Client
823+ forkIO $ do
824+ localNode <- newLocalNode transport initRemoteTable
825+ server <- readMVar addr
826+
827+ runProcess localNode $ do
828+ pid <- getSelfPid
829+ send server (Add pid 1 2)
830+ -- we only care about the client having sent a message, so we're done
831+ liftIO $ putMVar clientDone ()
832+
833+ takeMVar clientDone
834+ takeMVar serverDone
835+
836+-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
837+-- unless the text body @/= "bar"@ - this case should time out rather than
838+-- removing the message from the process mailbox.
839+testMatchAnyIf :: NT.Transport -> Assertion
840+testMatchAnyIf transport = do
841+ echoAddr <- newEmptyMVar
842+ clientDone <- newEmptyMVar
843+
844+ -- echo server
845+ forkIO $ do
846+ localNode <- newLocalNode transport initRemoteTable
847+ echoServer <- forkProcess localNode $ forever $ do
848+ receiveWait [
849+ matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
850+ handleMessage
851+ ]
852+ putMVar echoAddr echoServer
853+
854+ -- Client
855+ forkIO $ do
856+ localNode <- newLocalNode transport initRemoteTable
857+ server <- readMVar echoAddr
858+
859+ runProcess localNode $ do
860+ pid <- getSelfPid
861+ send server (pid, "foo")
862+ "foo" <- expect
863+ send server (pid, "baz")
864+ "baz" <- expect
865+ send server (pid, "bar")
866+ Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
867+ liftIO $ putMVar clientDone ()
868+
869+ takeMVar clientDone
870+ where handleMessage :: AbstractMessage -> Process (Maybe ())
871+ handleMessage msg =
872+ maybeHandleMessage msg (\(pid :: ProcessId, (m :: String))
873+ -> do { send pid m; return () })
874+
760875-- Test 'receiveChanTimeout'
761876testReceiveChanTimeout :: NT.Transport -> Assertion
762877testReceiveChanTimeout transport = do
@@ -987,6 +1102,9 @@ tests (transport, transportInternals) = [
9871102 , testCase "RemoteRegistry" (testRemoteRegistry transport)
9881103 , testCase "SpawnLocal" (testSpawnLocal transport)
9891104 , testCase "MatchAny" (testMatchAny transport)
1105+ , testCase "MatchAnyHandle" (testMatchAnyHandle transport)
1106+ , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle transport)
1107+ , testCase "MatchAnyIf" (testMatchAnyIf transport)
9901108 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)
9911109 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures transport)
9921110 , testCase "KillLocal" (testKillLocal transport)