1 module Main where

     2 

     3 import Network

     4 import IO

     5 import System.IO

     6 import Control.Concurrent

     7 import Control.Concurrent.STM

     8 import Control.Exception (finally)

     9 import Control.Monad (forM, filterM, liftM)

    10 import Miscutils

    11 

    12 type Client = (TChan String, Handle)

    13 

    14 acceptLoop :: Socket -> TChan Client -> IO ()

    15 acceptLoop servSock acceptChan = do

    16 	(cHandle, host, port) <- accept servSock

    17 	cChan <- atomically newTChan

    18 	forkIO $ clientLoop cHandle cChan

    19 	atomically $ writeTChan acceptChan (cChan, cHandle)

    20 	acceptLoop servSock acceptChan

    21 

    22 listenLoop :: Handle -> TChan String -> IO ()

    23 listenLoop handle chan = do

    24 	str <- hGetLine handle

    25 	atomically $ writeTChan chan str

    26 	listenLoop handle chan

    27 

    28 clientLoop :: Handle -> TChan String -> IO ()

    29 clientLoop handle chan =

    30 	listenLoop handle chan

    31 		`catch` (const $ clientOff >> return ())

    32 		`finally` hClose handle

    33 	where clientOff = atomically $ writeTChan chan "QUIT"

    34 

    35 mainLoop :: Socket -> TChan Client -> [Client] -> IO ()

    36 mainLoop servSock acceptChan clients = do

    37 	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)

    38 	case r of

    39 		Left (ch, h) -> do

    40 			mainLoop servSock acceptChan $ (ch, h):clients

    41 		Right (line, handle) -> do

    42 			clients' <- forM clients $ 

    43 					\(ch, h) -> do

    44 						hPutStrLn h line

    45 						hFlush h

    46 						return [(ch,h)]

    47 					`catch` const (hClose h >> return [])

    48 			mainLoop servSock acceptChan $ concat clients'

    49 

    50 tselect :: [(TChan a, t)] -> STM (a, t)

    51 tselect = foldl orElse retry . map (\(ch, ty) -> (flip (,) ty) `fmap` readTChan ch)

    52 

    53 startServer serverSocket = do

    54 	acceptChan <- atomically newTChan

    55 	forkIO $ acceptLoop serverSocket acceptChan

    56 	mainLoop serverSocket acceptChan []

    57 

    58 main = withSocketsDo $ do 

    59 	serverSocket <- listenOn $ Service "hedgewars"

    60 	startServer serverSocket `finally` sClose serverSocket