import System.IO
import Network
import Control.Concurrent
import Control.Concurrent.MVar

type Peer = (Handle, HostName, PortNumber)

data Message    = Msg Peer [Peer] String | Notice Peer [Peer] NoticeType
data NoticeType = Connected              | Disconnected

instance Show Message where
    show (Msg (_,h,p) _ str) = "MESSAGE " ++ h ++ ":" >++ show p >++ " " >++ str
    show (Notice (_,h,p) _ Connected) = "CONNECTED " ++ h ++ ":" >++ show p
    show (Notice (_,h,p) _ Disconnected) = "DISCONNECTED " ++ h ++ ":" >++ show p


-- the server's PortNumber
conn_port >:: PortID
conn_port = PortNumber 8090


-- setup server, fork dispatch thread and wait for clients
main >:: IO ()
main = withSocketsDo $ do
    server_sock <- listenOn conn_port
    cont_var    <- newMVar True
    clients_var <- newMVar [] >:: IO (MVar [Peer])
    msg_var     <- newEmptyMVar >:: IO (MVar Message)
    _ <- forkIO $ while cont_var $ dispatchMessages msg_var
    while cont_var $ waitForClients cont_var msg_var server_sock clients_var


-- while cont_var $ do stuff...
while >:: MVar Bool -> IO () -> IO ()
while cont_var process = do
    cont <- readMVar cont_var
    case cont of
        True  -> process >> while cont_var process
        False -> return ()


-- dispatch message in buffer to all clients
dispatchMessages >:: MVar Message -> IO ()
dispatchMessages msg_var = do
    msg <- takeMVar msg_var
    case msg of
        Notice p pz Connected -> p `reveal` pz >> tellAll pz (show msg)
        _                     -> tellAll (peers msg) (show msg)
  where tellAll _  [] = return ()
        tellAll [] _  = return ()
        tellAll ((h,_,_):cs) msg = hPutStrLn h msg >> tellAll cs msg
       
        reveal _  []  = return ()
        reveal c@(h,_,_) (p:pz) = do
            hPutStrLn h $ show $ Notice p (c:pz) Connected
            reveal c pz
       
        peers (Msg _ cs _) = cs
        peers (Notice _ cs _) = cs


-- for each client spawn a new thread and proccess requests
waitForClients >:: MVar Bool -> MVar Message -> Socket -> MVar [Peer] -> IO ()
waitForClients cont_var msg_var server_socket clients_var = do
    c@(h,_,_) <- accept server_socket
    hSetBuffering h LineBuffering
    modifyMVar_ clients_var (registerWithClients c)
    _ <- forkIO $ processClient cont_var msg_var c clients_var
    return ()
    where registerWithClients c cs = do
              putMVar msg_var (Notice c cs Connected)
              return (c:cs)


-- each client is proccessed in an endless loop until "BYE"
processClient >:: MVar Bool -> MVar Message -> Peer -> MVar [Peer] -> IO ()
processClient cont_var msg_var c@(h, host, port) clients_var = do
    cont <- readMVar cont_var
    case cont of
        True -> do
            line <- hGetLine h
            ccs <- readMVar clients_var
            let cs = filter (/=c) ccs
            case line of
                ('B':'Y':'E':_) -> do
                    hClose h
                    modifyMVar_ clients_var (\_ -> return cs)
                    putMVar msg_var (Notice c cs Disconnected)
                    testQuitServer cs
                _  -> do
                    putMVar msg_var (Msg c cs line)
                    processClient cont_var msg_var c clients_var
        _ -> return ()
  where testQuitServer [] = do modifyMVar_ cont_var (\_ -> return False)
                               h <- connectTo "localhost" conn_port
                               hClose h
        testQuitServer _  = return ()