@@ -0,0 +1,52 @@
1+import Network.Transport
2+import Network.Transport.TCP (createTransport)
3+import Control.Concurrent
4+import Data.Map
5+import Control.Exception
6+import System.Environment
7+
8+-- | Server that echoes messages straight back to the origin endpoint.
9+echoServer :: EndPoint -> MVar () -> IO ()
10+echoServer endpoint serverDone = go empty
11+ where
12+ go :: Map ConnectionId (MVar Connection) -> IO ()
13+ go cs = do
14+ event <- receive endpoint
15+ case event of
16+ ConnectionOpened cid rel addr -> do
17+ connMVar <- newEmptyMVar
18+ forkIO $ do
19+ Right conn <- connect endpoint addr rel
20+ putMVar connMVar conn
21+ go (insert cid connMVar cs)
22+ Received cid payload -> do
23+ forkIO $ do
24+ conn <- readMVar (cs ! cid)
25+ send conn payload
26+ return ()
27+ go cs
28+ ConnectionClosed cid -> do
29+ forkIO $ do
30+ conn <- readMVar (cs ! cid)
31+ close conn
32+ go (delete cid cs)
33+ EndPointClosed -> do
34+ putStrLn "Echo server exiting"
35+ putMVar serverDone ()
36+
37+onCtrlC :: IO a -> IO () -> IO a
38+p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
39+ where
40+ isUserInterrupt :: AsyncException -> Maybe ()
41+ isUserInterrupt UserInterrupt = Just ()
42+ isUserInterrupt _ = Nothing
43+
44+main :: IO ()
45+main = do
46+ [host, port] <- getArgs
47+ serverDone <- newEmptyMVar
48+ Right transport <- createTransport host port
49+ Right endpoint <- newEndPoint transport
50+ forkIO $ echoServer endpoint serverDone
51+ putStrLn $ "Echo server started at " ++ show (address endpoint)
52+ readMVar serverDone `onCtrlC` closeTransport transport