DSTM-0.1: Chat/ChatServer.hs

module Main where

import ChatData
import Control.Distributed.STM.DebugDSTM
import Control.Distributed.STM.DSTM
import Control.Exception as CE
import Maybe

main :: IO ()
main = startDist $ do
  inVar <- atomic $ newTVar Nothing
  registerTVar "localhost" inVar "Chat"
  chatServer inVar []

chatServer :: CmdTVar -> [(String, CmdTVar)] -> IO ()
chatServer inCmd dict = CE.catch (do
  newDict <- atomic $ do
    cmd <- readTVar inCmd
    case cmd of
      Nothing -> do
                 mapM_ (readTVar.snd) dict
                 retry
      Just serverCmd -> do
        writeTVar inCmd Nothing
        case serverCmd of
          Join name msgVar -> do
             proc $ putStrLn (name++" joint the chat")
             mapM_ (flip writeTVar msg.snd) dict
             return ((name,msgVar):dict)
             where msg = Just (Msg name " joint")
          Msg _ _ -> do
             proc $ putStrLn "Message forwarded"
             mapM_ (flip writeTVar cmd.snd) dict
	     return dict
          Leave name -> do
             proc $ putStrLn (name++" left the chat")
	     mapM_ (flip writeTVar msg.snd) dic
             return dic
             where msg = Just (Msg name " left")
                   dic = filter ((/=name).fst) dict
  chatServer inCmd newDict
  )(\e -> print "Dropped Client" >> chatServer inCmd (removeErrDict e dict))

removeErrDict :: SomeDistTVarException -> [(String, CmdTVar)] 
                 -> [(String, CmdTVar)]
removeErrDict e dict = [d | d <- dict, not (isDistErrTVar e (snd d))]