module Control.Concurrent.Network.Master
(
initMaster
) where
import Control.Concurrent.Network.Protocol
import Network
import System.IO
import Data.Binary
import Data.ByteString.Lazy as DBL
import Data.Map
import Control.Monad
import Control.Monad.Loops
import Control.Concurrent
import System.Log.Logger
data MMVar = MMV
{ dat :: ByteString
, empt :: Bool
}
data Master = M
{ registry :: MVar (Map String MMVar)
, slaveid :: Int
, numslaves :: Int
}
initMaster :: Int -> PortID -> IO ()
initMaster n p = do
debugM rootLoggerName "Initialise master"
sck <- listenOn p
slcnt <- newMVar 0
slid <- newMVar 0
reg <- newMVar $ fromList []
mcntx <- return $ M { registry = reg }
replicateM_ n $ do
tid <- forkIO $ do
slaveid' <- takeMVar slid
putMVar slid $ slaveid' + 1
mymcntx <- return $ mcntx { slaveid = slaveid', numslaves = n }
(hdl, hname, pnum) <- accept sck
infoM rootLoggerName $ hname ++ " <slave " ++ show slaveid' ++
"> connected from port " ++ show pnum
hSetBuffering hdl NoBuffering
untilM_ (do
p <- readProtoId hdl
debugM rootLoggerName $ (show slaveid') ++ "==> " ++ show p
handlePacket mymcntx hdl p
debugM rootLoggerName $ (show slaveid') ++ "<== " ++ show p
) $ hIsEOF hdl
modifyMVar_ slcnt (\c -> return $ c + 1)
infoM rootLoggerName $ "thread " ++ show tid ++ " is waiting for connections.."
debugM rootLoggerName "Waiting for internal threads.."
untilM_ yield $ do
cnt <- readMVar $ slcnt
return $ cnt == n
handlePacket :: Master -> Handle -> ProtoId -> IO ()
handlePacket mcntx hdl NNV = do
name <- readBinary hdl
modifyMVar_ (registry mcntx) $ return . (insert name MMV { empt = True })
handlePacket mcntx hdl TPN = do
name <- readBinary hdl
val <- readByteString hdl
reg <- takeMVar (registry mcntx)
if (not $ member name reg) || (not $ empt $ reg ! name)
then do
putMVar (registry mcntx) reg
writeBinary hdl False
else do
putMVar (registry mcntx) $ insert name MMV { dat = val, empt = False } reg
writeBinary hdl True
handlePacket mcntx hdl TTN = do
name <- readBinary hdl
reg <- takeMVar (registry mcntx)
if (not $ member name reg) || (empt $ reg ! name)
then do
putMVar (registry mcntx) reg
writeBinary hdl False
else do
val <- return $ reg ! name
putMVar (registry mcntx) $ insert name val { empt = True } reg
writeBinary hdl True
writeByteString hdl $ dat $ val
handlePacket mcntx hdl PNV = do
name <- readBinary hdl
val <- readByteString hdl
untilM_ yield $ do
reg <- takeMVar (registry mcntx)
if not $ member name reg
then putMVar (registry mcntx) reg >> return False
else if not $ empt $ reg ! name
then putMVar (registry mcntx) reg >> return False
else do
putMVar (registry mcntx) $ insert name MMV { dat = val, empt = False } reg
return True
writeProtoId hdl PNV
handlePacket mcntx hdl TNV = do
name <- readBinary hdl
untilM_ yield $ do
reg <- takeMVar (registry mcntx)
if not $ member name reg
then putMVar (registry mcntx) reg >> return False
else if empt $ reg ! name
then putMVar (registry mcntx) reg >> return False
else do
val <- return $ reg ! name
writeByteString hdl $ dat val
putMVar (registry mcntx) $ insert name val { empt = True } reg
return True
handlePacket mcntx hdl PWO = do
name <- readBinary hdl
op <- readBinary hdl
val <- readByteString hdl
untilM_ yield $ do
reg <- takeMVar (registry mcntx)
if not $ member name reg
then putMVar (registry mcntx) reg >> return False
else if empt $ reg ! name
then putMVar (registry mcntx) reg >> return False
else if (dat (reg ! name) /= val && op == EQOP) ||
(dat (reg ! name) == val && op == NEQOP)
then putMVar (registry mcntx) reg >> return True
else putMVar (registry mcntx) reg >> return False
writeProtoId hdl PWO
handlePacket mcntx hdl SID = writeBinary hdl $ slaveid mcntx
handlePacket mcntx hdl NSL = writeBinary hdl $ numslaves mcntx
handlePacket _ hdl PMS = readBinary hdl >>= System.IO.putStrLn