@@ -0,0 +1,52 @@
1+import Network.Transport
2+import Network.Transport.TCP (createTransport)
3+import Control.Concurrent
5+import Control.Exception
6+import System.Environment
8+-- | Server that echoes messages straight back to the origin endpoint.
9+echoServer :: EndPoint -> MVar () -> IO ()
10+echoServer endpoint serverDone = go empty
12+ go :: Map ConnectionId (MVar Connection) -> IO ()
14+ event <- receive endpoint
16+ ConnectionOpened cid rel addr -> do
17+ connMVar <- newEmptyMVar
19+ Right conn <- connect endpoint addr rel
20+ putMVar connMVar conn
21+ go (insert cid connMVar cs)
22+ Received cid payload -> do
24+ conn <- readMVar (cs ! cid)
28+ ConnectionClosed cid -> do
30+ conn <- readMVar (cs ! cid)
34+ putStrLn "Echo server exiting"
35+ putMVar serverDone ()
37+onCtrlC :: IO a -> IO () -> IO a
38+p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
40+ isUserInterrupt :: AsyncException -> Maybe ()
41+ isUserInterrupt UserInterrupt = Just ()
42+ isUserInterrupt _ = Nothing
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