Merge pull request #11 from qnikst/remote-registry

Test if it's possible to send message to remote nodes in Registry

Author: qnikst

src/Control/Distributed/Process/Tests/CH.hs

@@ -658,6 +658,26 @@ testRegistry TestTransport{..} = do
 
   takeMVar done
 
+testRegistryRemoteProcess :: TestTransport -> Assertion
+testRegistryRemoteProcess TestTransport{..} = do
+  node1 <- newLocalNode testTransport initRemoteTable
+  node2 <- newLocalNode testTransport initRemoteTable
+  done <- newEmptyMVar
+
+  pingServer <- forkProcess node1 ping
+
+  runProcess node2 $ do
+    register "ping" pingServer
+    Just pid <- whereis "ping"
+    True <- return $ pingServer == pid
+    us <- getSelfPid
+    nsend "ping" (Pong us)
+    Ping pid' <- expect
+    True <- return $ pingServer == pid'
+    liftIO $ putMVar done ()
+
+  takeMVar done
+
 testRemoteRegistry :: TestTransport -> Assertion
 testRemoteRegistry TestTransport{..} = do
   node1 <- newLocalNode testTransport initRemoteTable
@@ -702,6 +722,30 @@ testRemoteRegistry TestTransport{..} = do
 
   takeMVar done
 
+testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
+testRemoteRegistryRemoteProcess TestTransport{..} = do
+  node1 <- newLocalNode testTransport initRemoteTable
+  node2 <- newLocalNode testTransport initRemoteTable
+  done <- newEmptyMVar
+
+  pingServer <- forkProcess node2 ping
+
+  runProcess node2 $ do
+    let nid1 = localNodeId node1
+    registerRemoteAsync nid1 "ping" pingServer
+    receiveWait [
+       matchIf (\(RegisterReply label' _ _) -> "ping" == label')
+               (\(RegisterReply _ _ _) -> return ()) ]
+    Just pid <- whereisRemote nid1 "ping"
+    True <- return $ pingServer == pid
+    us <- getSelfPid
+    nsendRemote nid1 "ping" (Pong us)
+    Ping pid' <- expect
+    True <- return $ pingServer == pid'
+    liftIO $ putMVar done ()
+
+  takeMVar done
+
 testSpawnLocal :: TestTransport -> Assertion
 testSpawnLocal TestTransport{..} = do
   node <- newLocalNode testTransport initRemoteTable
@@ -1468,7 +1512,9 @@ tests testtrans = return [
       , testCase "MergeChannels"       (testMergeChannels       testtrans)
       , testCase "Terminate"           (testTerminate           testtrans)
       , testCase "Registry"            (testRegistry            testtrans)
+      , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess      testtrans)
       , testCase "RemoteRegistry"      (testRemoteRegistry      testtrans)
+      , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess      testtrans)
       , testCase "SpawnLocal"          (testSpawnLocal          testtrans)
       , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
       , testCase "HandleMessageIf"     (testHandleMessageIf     testtrans)