messageManager.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import System.Timeout
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
 
 
send msg = do
  --dummy stub
  print msg
 
-- type classes, mailing list
newtype SequenceNumber = SeqN Int
  deriving (Eq, Show, Enum, Num, Bounded)
 
instance Ord SequenceNumber where
  a <= b | a - b > 0 = False
  a <= b = True
 
inc :: (Num a) => a -> a
inc = (+ 1)
 
sequencePlus :: (Monad m, MonadPlus n, Eq (n a)) => n a -> [m (n a)] -> m (n a)
sequencePlus a [] = return a
sequencePlus a _ | a /= mzero = return a
sequencePlus a (x:xs) = x >>= \b -> sequencePlus (a `mplus` b) xs
 
sendWithTimeout :: (Show a, Eq b) => a -> MVar b -> IO (Maybe b)
sendWithTimeout msg responseMVar = sequencePlus Nothing $
                 replicate 3 $ timeout 100 $ send msg >> takeMVar responseMVar
    stopWaitingForResponse
  
sendMsg :: (Show a, Eq b) => a -> (Maybe b -> IO c) -> IO (MVar b)
sendMsg responseHandler msg = do
    responseMVar <- newEmptyMVar
    forkIO $ sendWithTimeout msg responseMVar >>= responseHandler >> return ()
    return responseMVar
 
sendMgmtMsg client msg = do
  seqNumber <- getNextSeq client
  responseMVar <- sendMsg (mgmtReponseHandler client) $ MgmtMsg seqNumber msg
  watchForResponse client seqNumber responseMVar
 
recieveMgmtMsg client (MgmtAck seqNumber) = do
  table <- getResponseTable
  case lookup client table >>= lookup seqNumber of
    Just mVar -> tryPutMVar mVar msg
    Nothing -> return False


send msg, client, seq
msg, client, seq <- recv 

client needs to be external identifier,
seq is internal
data ManagerMessage a = Ack SequenceNumber
                      | Msg a

sendMngMsg, handleMngMsg <- initializeMessageHandler putInOutbox putInInbox

sender :: ManagerMessage a -> IO b
sendMngMsg (Ord clientId) => clientId -> ManagerMessage a -> IO ()
handleResponse 
send :: (Ord clientId) => clientId -> ManagerMessage -> IO ()
sendHandleResponse :: (Ord clientId) => clientId -> ManagerMessage -> (Maybe ManagerMessage -> IO a) -> IO ()
recv :: ManagerMessage -> IO a