Simple distributed Ping

gistfile1.hs

{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Main where

import System.Environment (getArgs, getProgName)
import Data.Typeable
import Data.Binary
import Control.Concurrent (threadDelay)
import Control.Distributed.Process.Backend.SimpleLocalnet
import Control.Distributed.Process
import Control.Distributed.Process.Node hiding (newLocalNode)
import Control.Distributed.Process.Closure

newtype Ping = Ping ProcessId
  deriving (Typeable, Binary, Show)

newtype Pong = Pong ProcessId
  deriving (Typeable, Binary, Show)

worker :: Ping -> Process ()
worker (Ping master) = do
  wId <- getSelfPid
  say "Got a Ping!"
  send master (Pong wId)
  
remotable ['worker]

initialProcess :: String -> Backend -> [NodeId] -> Process ()
initialProcess "WORKER" backend peers = do
  say $ "Peers: " ++ show peers
  pid <- getSelfPid
  register "slaveController" pid
  receiveWait []
initialProcess "MASTER" backend workers = do
  say $ "Workers: " ++ show workers
  pid <- getSelfPid

  mapM_ (\w -> do
          say $ "Sending a Ping to " ++ (show w) ++ "..."
          spawn w ($(mkClosure 'worker) (Ping pid))) workers
  say $ "Waiting for reply from " ++ (show (length workers)) ++ " worker(s)"
  mapM_ (\_ -> do
          let resultMatch = match (\(Pong wId) -> return wId)
            in do wId <- receiveWait [resultMatch]
                  say $ "Got back a Pong from "
                    ++ (show $ processNodeId wId) ++ "!") workers
  (liftIO . threadDelay) 2000000 -- Wait a bit before return

main = do
  prog <- getProgName
  args <- getArgs

  case args of
    ["master", host, port] -> do
      backend <- initializeBackend host port (__remoteTable initRemoteTable) 
      startMaster backend (initialProcess "MASTER" backend)
    ["worker", host, port] -> do
      backend <- initializeBackend host port (__remoteTable initRemoteTable) 
      node <- newLocalNode backend 
      peers <- findPeers backend 50000
      runProcess node (initialProcess "WORKER" backend peers)
    _ -> 
      putStrLn $ "usage: " ++ prog ++ " (master | worker) host port"