distributed-process-0.7.5: benchmarks/Spawns.hs

{-# LANGUAGE BangPatterns #-}

-- | Like Throughput, but send every ping from a different process
-- (i.e., require a lightweight connection per ping)
import System.Environment
import Control.Monad
import Control.Applicative
import Control.Distributed.Process
import Control.Distributed.Process.Node
import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
import Data.Binary (encode, decode)
import qualified Data.ByteString.Lazy as BSL

counter :: Process ()
counter = go 0
  where
    go :: Int -> Process ()
    go !n = do
      b <- expect
      case b of
        Nothing   -> go (n + 1)
        Just them -> send them n >> go 0

count :: Int -> ProcessId -> Process ()
count n them = do
  us <- getSelfPid
  replicateM_ n . spawnLocal $ send them (Nothing :: Maybe ProcessId)
  send them (Just us)
  n' <- expect
  liftIO $ print (n == n')

initialProcess :: String -> Process ()
initialProcess "SERVER" = do
  us <- getSelfPid
  liftIO $ BSL.writeFile "counter.pid" (encode us)
  counter
initialProcess "CLIENT" = do
  n <- liftIO $ getLine
  them <- liftIO $ decode <$> BSL.readFile "counter.pid"
  count (read n) them

main :: IO ()
main = do
  [role, host, port] <- getArgs
  trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
  case trans of
    Right transport -> do node <- newLocalNode transport initRemoteTable
                          runProcess node $ initialProcess role
    Left other -> error $ show other