git.iko.soy/distributed-process
on d866e29 help sign in
distributed-process/doc/tutorial/tutorial-server.hs
52 lines 1.7 kB history raw
1import Network.Transport
2import Network.Transport.TCP (createTransport)
3import Control.Concurrent
4import Data.Map
5import Control.Exception
6import System.Environment
8-- | Server that echoes messages straight back to the origin endpoint.
9echoServer :: EndPoint -> MVar () -> IO ()
10echoServer 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 ()
37onCtrlC :: IO a -> IO () -> IO a
38p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
39 where
40 isUserInterrupt :: AsyncException -> Maybe ()
41 isUserInterrupt UserInterrupt = Just ()
42 isUserInterrupt _ = Nothing
44main :: IO ()
45main = 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