Glimpse of Cloud Haskell http://www.well-typed.com/blog/68

pingpong-0.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Control.Concurrent ( threadDelay )
import Data.Binary
import Data.Typeable

import Control.Distributed.Process
import Control.Distributed.Process.Node
import Network.Transport.TCP

-- Serializable (= Binary + Typeable)
data Ping = Ping deriving (Typeable)

instance Binary Ping where
    put Ping = putWord8 0
    get      = do { getWord8; return Ping }

server :: ReceivePort Ping -> Process ()
server rPing = do
    Ping <- receiveChan rPing
    liftIO $ putStrLn "Got a ping!"

client :: SendPort Ping -> Process ()
client sPing =
    sendChan sPing Ping

ignition :: Process ()
ignition = do
    -- start the server
    sPing <- spawnChannelLocal server
    -- start the client
    spawnLocal $ client sPing
    liftIO $ threadDelay 100000 -- wait a while

main :: IO ()
main = do
    Right transport <- createTransport "127.0.0.1" "8080"
                            defaultTCPParameters
    node <- newLocalNode transport initRemoteTable
    runProcess node ignition

pingpong-1.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Control.Concurrent ( threadDelay )
import Data.Binary
import Data.Typeable

import Control.Distributed.Process
import Control.Distributed.Process.Node
import Network.Transport.TCP

-- Serializable (= Binary + Typeable)
data Ping = Ping (SendPort Pong) deriving (Typeable)
data Pong = Pong deriving (Typeable)

instance Binary Ping where
    put (Ping sPong) = put sPong
    get      = do { sPong <- get; return (Ping sPong)}

instance Binary Pong where
    put Pong = putWord8 0
    get      = do { getWord8; return Pong }

server :: ReceivePort Ping -> Process ()
server rPing = do
    (Ping sPong) <- receiveChan rPing
    liftIO $ putStrLn "Got a ping!"
    sendChan sPong Pong

client :: SendPort Ping -> Process ()
client sPing = do
    (sPong, rPong) <- newChan
    sendChan sPing (Ping sPong)
    Pong <- receiveChan rPong
    liftIO $ putStrLn "Got a pong!"

ignition :: Process ()
ignition = do
    -- start the server
    sPing <- spawnChannelLocal server
    -- start the client
    spawnLocal $ client sPing
    liftIO $ threadDelay 100000 -- wait a while

main :: IO ()
main = do
    Right transport <- createTransport "127.0.0.1" "8080"
                            defaultTCPParameters
    node <- newLocalNode transport initRemoteTable
    runProcess node ignition

pingpong-2.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Control.Concurrent ( threadDelay )
import Control.Monad (forever)
import Data.Binary
import Data.Typeable

import Control.Distributed.Process
import Control.Distributed.Process.Node
import Network.Transport.TCP

-- Serializable (= Binary + Typeable)
data Ping = Ping (SendPort Pong) deriving (Typeable)
data Pong = Pong deriving (Typeable)

instance Binary Ping where
    put (Ping sPong) = put sPong
    get      = do { sPong <- get; return (Ping sPong) }

instance Binary Pong where
    put Pong = putWord8 0
    get      = do { getWord8; return Pong }

server :: ReceivePort Ping -> Process ()
server rPing = forever $ do
    (Ping sPong) <- receiveChan rPing
    liftIO $ putStrLn "Got a ping!"
    sendChan sPong Pong

client :: SendPort Ping -> Process ()
client sPing = newChan >>= \(sPong, rPong) -> forever $ do
    sendChan sPing (Ping sPong)
    Pong <- receiveChan rPong
    liftIO $ putStrLn "Got a pong!"

ignition :: Process ()
ignition = do
    -- start the server
    sPing <- spawnChannelLocal server
    -- start the client
    spawnLocal $ client sPing
    liftIO $ threadDelay 1000000 -- wait a while

main :: IO ()
main = do
    Right transport <- createTransport "127.0.0.1" "8080"
                            defaultTCPParameters
    node <- newLocalNode transport initRemoteTable
    runProcess node ignition