import IO
import Control.Exception hiding (catch)
import Control.Concurrent
import Network
import System.Posix

main = withSocketsDo (installHandler sigPIPE Ignore Nothing >> main')
main' = listenOn (PortNumber 9900) >>= acceptConnections

acceptConnections sock = do
        putStrLn "trying to accept" -- debug msg
        conn@(h,host,port) <- accept sock
        print conn -- debug msg
        forkIO $ catch (talk conn `finally` hClose h) (\e -> print e)
        acceptConnections sock

talk conn@(h,_,_) = hGetLine h >>= hPutStrLn h >> hFlush h >> talk conn

import IO
import Control.Exception hiding (catch)
import Control.Concurrent
import Network
import System.Posix
import List
import Monad

main = withSocketsDo (installHandler sigPIPE Ignore Nothing >> main')
main' = do
    sock <- listenOn (PortNumber 9901)
    mvH <- newMVar [] -- list of client handles
    mvM <- newMVar [] -- messags stack ... not queue :)
    mvS <- newEmptyMVar -- semaphore
    let mvt = (mvH,mvM,mvS)
    forkIO $ broadcast mvt `finally` putMVar mvS ()
    acceptConnections sock mvt

acceptConnections sock mvt@(mvH,mvM,_ ) = do
    print "trying to accept" -- for debugging message
    conn@(h,host,port) <- accept sock
    print conn -- for debugging message
    modifyMVar_ mvH (return . (h:))
    forkIO $ catch (talk conn mvt `finally` closeConn h mvH) print
    acceptConnections sock mvt

talk conn@(h,host,port) mvt@(_ ,mvM,mvS) =
    hGetLine h >>= stackMsg >> talk conn mvt
    where stackMsg m = do
        modifyMVar_ mvM (return . ((show (host,port)++':':m):))
        tryPutMVar mvS () -- V

closeConn h mvH = modifyMVar_ mvH (return . delete h) >> hClose h

broadcast mvt@(mvH,mvM,mvS) = do
    takeMVar mvS -- P
    ms <- swapMVar mvM []
    mapM_ (\m ->mapM_ (failSafe(\h->hPutStrLn h m>>hFlush h))=<<readMVar mvH) ms
    broadcast mvt
    where failSafe ioWithHarg h = catch (ioWithHarg h) print