handoff.hs

{-# LANGUAGE DeriveDataTypeable,DeriveGeneric #-}
import Control.Distributed.Process
import Network.Transport.TCP
import Control.Distributed.Process.Node (initRemoteTable,newLocalNode,forkProcess)
import Prelude hiding (log)
import GHC.Generics (Generic)
import Data.Binary
import Data.Typeable
import Control.Concurrent

data Measurement = DummyMeasurement deriving (Show,Typeable,Generic)

data HandoffMsg = HOCommand'
                | HOReq 
                | HOConnect
                | Flush
                | Activation
                | LinkActReq
                | LinkEstablished 
                | LinkActive ProcessId
                | HOAck ProcessId
                | HOCommand ProcessId
                deriving (Show,Typeable,Generic,Eq)
short = zip [(0::Word8) ..]
          [HOCommand', HOReq , HOConnect, Flush, Activation, LinkActReq, LinkEstablished]
trohs = map (\(x,y)->(y,x)) short
instance Binary Measurement where
    put DummyMeasurement = put ()
    get = do x <- get :: Get ()
             return DummyMeasurement
instance Binary HandoffMsg where
    put x = case lookup x trohs of 
              Just n -> put x
              Nothing -> case x of LinkActive pid -> put (7::Word8) >> put pid
                                   HOAck pid -> put (8::Word8) >> put pid
                                   HOCommand pid -> put (9::Word8) >> put pid
    get = do x <- get :: Get Word8
             case lookup x short of 
                      Just msg -> return msg
                      Nothing -> case x of 7 -> do pid <- get ::  Get ProcessId
                                                   return $ LinkActive pid
                                           8 -> do pid <- get ::  Get ProcessId
                                                   return $ HOAck pid
                                           9 -> do pid <- get ::  Get ProcessId
                                                   return $ HOCommand pid

ms :: Measurement -> Process ()
ms measurement = do
  bs <- expect
  self <- getSelfPid
  go bs measurement
 where
  go bs measurement = do
  self <- getSelfPid
  liftIO $ threadDelay 4800000
  liftIO $ putStrLn $ "At MS - " ++ show (self,bs)
  send bs (measurement,self) 
  receiveTimeout 0
    [ match $ \(LinkActive newbs,bs) -> do
  liftIO $ log bs self (LinkActive newbs)
  send newbs (LinkActReq,self)
    , match $ \(LinkEstablished,new) -> do
  liftIO $ log new self LinkEstablished
    , matchUnknown $ do
  liftIO $ putStrLn $ "Matched Unknown message at " ++ show (self,bs)
    ]  
  go bs measurement

bs :: Process () 
bs = do
  (bsc,ms) <- expect :: Process (ProcessId,ProcessId)
  go bsc ms
 where 
  go bsc ms = do
  self <- getSelfPid
  liftIO $ putStrLn $ "At bs - " ++ show (self,bsc,ms)
  receiveWait
    [ match $ \(DummyMeasurement,ms) -> do
  liftIO $ log ms self HOConnect
  -- decide whether to initiate handoff 
  -- send bsc (HOReq,self)
  send bsc "Ack"
    , matchUnknown $ do
  liftIO $ putStrLn $ "Matched Unknown message at " ++ show (self,bsc,ms)
    ]  
  go bsc ms

bsc :: Process ()
bsc = do
--  (bs,msc) <- expect
  go
 where
  go = do
  self <- getSelfPid
  liftIO $ putStrLn $ "At BSC - " ++ show (self)
  receiveWait
    [ match $ \(HOReq,oldbs) -> do
  liftIO $ log oldbs self HOReq 
--  send msc (HOReq,self)
    , matchUnknown $ do
  liftIO $ putStrLn $ "Matched Unknown message at " ++ show (self)
    ]
  go


log :: ProcessId -> ProcessId -> HandoffMsg -> IO ()
log from to msg = putStrLn $ show to ++ " <--- " ++ show from ++ " ---- " ++ show msg

master :: Process ()
master = do
  oldbscId      <- spawnLocal bsc
  oldbsId       <- spawnLocal bs
  newbsId       <- spawnLocal bs
  msId          <- spawnLocal $ ms DummyMeasurement
  
  oldbscref     <- monitor oldbscId
  oldbsref      <- monitor oldbsId
  newbsref      <- monitor newbsId
  msref         <- monitor msId

  send msId oldbsId
  send oldbsId (oldbscId,msId)

  go 
 where 
  go = do
  receiveWait 
    [ match $ \(ProcessMonitorNotification ref id dr) -> do 
  liftIO $ putStrLn $ show (ref,id,dr)
    , matchUnknown $ do
  liftIO $ putStrLn "Matched Unknown at master"
    ]
  go
  

main :: IO ()
main = do
  either_ <- createTransport "127.0.0.1" "10501" defaultTCPParameters
  case either_ of Right t -> do 
                      node <- newLocalNode t initRemoteTable
                      putStrLn "Before launching processes"
                      forkProcess node master
                      threadDelay 100000000
                  Left x -> print x