git.iko.soy/distributed-process
on ryan help sign in
distributed-process/doc/tutorial/tutorial-server.hs
54 lines 1.9 kB history raw
1import Network.Transport
2import Network.Transport.TCP (createTransport, defaultTCPParameters)
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 putStrLn$ " New connection: ID "++show cid++", reliability: "++show rel++", address: "++ show addr
18 connMVar <- newEmptyMVar
19 forkIO $ do
20 Right conn <- connect endpoint addr rel defaultConnectHints
21 putMVar connMVar conn
22 go (insert cid connMVar cs)
23 Received cid payload -> do
24 forkIO $ do
25 conn <- readMVar (cs ! cid)
26 send conn payload
27 return ()
28 go cs
29 ConnectionClosed cid -> do
30 putStrLn$ " Closed connection: ID "++show cid
31 forkIO $ do
32 conn <- readMVar (cs ! cid)
33 close conn
34 go (delete cid cs)
35 EndPointClosed -> do
36 putStrLn "Echo server exiting"
37 putMVar serverDone ()
39onCtrlC :: IO a -> IO () -> IO a
40p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
41 where
42 isUserInterrupt :: AsyncException -> Maybe ()
43 isUserInterrupt UserInterrupt = Just ()
44 isUserInterrupt _ = Nothing
46main :: IO ()
47main = do
48 [host, port] <- getArgs
49 serverDone <- newEmptyMVar
50 Right transport <- createTransport host port defaultTCPParameters
51 Right endpoint <- newEndPoint transport
52 forkIO $ echoServer endpoint serverDone
53 putStrLn $ "Echo server started at " ++ show (address endpoint)
54 readMVar serverDone `onCtrlC` closeTransport transport