Concurrent echo server

Ertugrul Söylemez 2011-10-17 08:48:37.837005 UTC

1module Main where
2
3import Control.Concurrent
4import Control.Exception
5import Control.Monad
6import Network
7import System.IO
8import Text.Printf
9
10
11type Logger = String -> IO ()
12
13
14main :: IO ()
15main = do
16 log <- logger
17
18 sock <- listenOn (PortNumber 4000)
19 forkIO (server log sock)
20
21 log "Press enter to exit"
22 fmap (const ()) getLine
23
24
25 where
26 logger :: IO Logger
27 logger = do
28 logVar <- newEmptyMVar
29 forkIO . forever $ takeMVar logVar >>= putStrLn
30 return (putMVar logVar)
31
32 server :: Logger -> Socket -> IO ()
33 server log sock =
34 forever $ do
35 (h, caddr, cport) <- accept sock
36 log (printf "Connection from %s" caddr)
37 hSetBuffering h NoBuffering
38
39 forkIO $ (hGetContents h >>= hPutStr h)
40 `finally` hClose h