@@ -0,0 +1,107 @@
1+import System.Environment (getArgs)
2+import Network.Transport
3+import Network.Transport.TCP (createTransport)
4+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, modifyMVar_, modifyMVar)
5+import Control.Concurrent (forkIO)
6+import Control.Monad (forever, forM, unless, when)
7+import qualified Data.ByteString as BS (concat, null)
8+import qualified Data.ByteString.Char8 as BSC (pack, unpack, getLine)
9+import Data.Map (Map)
10+import qualified Data.Map as Map (fromList, elems, insert, member, empty, size, delete, (!))
11+
12+chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO ()
13+chatClient done endpoint serverAddr = do
14+ connect endpoint serverAddr ReliableOrdered
15+ cOut <- getPeers >>= connectToPeers
16+ cIn <- newMVar Map.empty
17+
18+ -- Listen for incoming messages
19+ forkIO . forever $ do
20+ event <- receive endpoint
21+ case event of
22+ Received _ msg ->
23+ putStrLn . BSC.unpack . BS.concat $ msg
24+ ConnectionOpened cid _ addr -> do
25+ modifyMVar_ cIn $ return . Map.insert cid addr
26+ didAdd <- modifyMVar cOut $ \conns ->
27+ if not (Map.member addr conns)
28+ then do
29+ Right conn <- connect endpoint addr ReliableOrdered
30+ return (Map.insert addr conn conns, True)
31+ else
32+ return (conns, False)
33+ when didAdd $ showNumPeers cOut
34+ ConnectionClosed cid -> do
35+ addr <- modifyMVar cIn $ \conns ->
36+ return (Map.delete cid conns, conns Map.! cid)
37+ modifyMVar_ cOut $ \conns -> do
38+ close (conns Map.! addr)
39+ return (Map.delete addr conns)
40+ showNumPeers cOut
41+
42+
43+
44+{-
45+ chatState <- newMVar (Map.fromList peerConns)
46+
47+ -- Thread to listen to incoming messages
48+ forkIO . forever $ do
49+ event <- receive endpoint
50+ case event of
51+ ConnectionOpened _ _ (EndPointAddress addr) -> do
52+ modifyMVar_ chatState $ \peers ->
53+ if not (Map.member addr peers)
54+ then do
55+ Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered
56+ return (Map.insert addr conn peers)
57+ else
58+ return peers
59+ Received _ msg ->
60+ putStrLn . BSC.unpack . BS.concat $ msg
61+ ConnectionClosed _ ->
62+ return ()
63+
64+-}
65+ -- Thread to interact with the user
66+ showNumPeers cOut
67+ let go = do
68+ msg <- BSC.getLine
69+ unless (BS.null msg) $ do
70+ readMVar cOut >>= \conns -> forM (Map.elems conns) $ \conn -> send conn [msg]
71+ go
72+ go
73+ putMVar done ()
74+
75+ where
76+ getPeers :: IO [EndPointAddress]
77+ getPeers = do
78+ ConnectionOpened _ _ _ <- receive endpoint
79+ Received _ msg <- receive endpoint
80+ ConnectionClosed _ <- receive endpoint
81+ return . map EndPointAddress . read . BSC.unpack . BS.concat $ msg
82+
83+ connectToPeers :: [EndPointAddress] -> IO (MVar (Map EndPointAddress Connection))
84+ connectToPeers addrs = do
85+ conns <- forM addrs $ \addr -> do
86+ Right conn <- connect endpoint addr ReliableOrdered
87+ return (addr, conn)
88+ newMVar (Map.fromList conns)
89+
90+ showNumPeers :: MVar (Map EndPointAddress Connection) -> IO ()
91+ showNumPeers cOut =
92+ readMVar cOut >>= \conns -> putStrLn $ "# " ++ show (Map.size conns) ++ " peers"
93+
94+
95+
96+
97+main :: IO ()
98+main = do
99+ host:port:server:_ <- getArgs
100+ Right transport <- createTransport host port
101+ Right endpoint <- newEndPoint transport
102+ clientDone <- newEmptyMVar
103+
104+ forkIO $ chatClient clientDone endpoint (EndPointAddress . BSC.pack $ server)
105+
106+ takeMVar clientDone
107+