4 import IO |
4 import IO |
5 import System.IO |
5 import System.IO |
6 import Control.Concurrent |
6 import Control.Concurrent |
7 import Control.Concurrent.STM |
7 import Control.Concurrent.STM |
8 import Control.Exception (setUncaughtExceptionHandler, handle, finally) |
8 import Control.Exception (setUncaughtExceptionHandler, handle, finally) |
9 import Control.Monad (forM, forM_, filterM, liftM, unless) |
9 import Control.Monad (forM, forM_, filterM, liftM, when, unless) |
10 import Maybe (fromMaybe) |
10 import Maybe (fromMaybe) |
11 import Data.List |
11 import Data.List |
12 import Miscutils |
12 import Miscutils |
13 import HWProto |
13 import HWProto |
14 import Opts |
14 import Opts |
15 |
15 |
16 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
16 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
17 acceptLoop servSock acceptChan = do |
17 acceptLoop servSock acceptChan = do |
18 (cHandle, host, port) <- accept servSock |
18 (cHandle, host, port) <- accept servSock |
|
19 hPutStrLn cHandle "CONNECTED\n" |
|
20 hFlush cHandle |
19 cChan <- atomically newTChan |
21 cChan <- atomically newTChan |
20 forkIO $ clientLoop cHandle cChan |
22 forkIO $ clientLoop cHandle cChan |
21 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
23 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
22 hPutStrLn cHandle "CONNECTED\n" |
|
23 hFlush cHandle |
|
24 acceptLoop servSock acceptChan |
24 acceptLoop servSock acceptChan |
25 |
25 |
26 |
26 |
27 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
27 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
28 listenLoop handle buf chan = do |
28 listenLoop handle buf chan = do |
75 let mclients = (clientsFunc clients) |
75 let mclients = (clientsFunc clients) |
76 let mclient = fromMaybe client $ find (== client) mclients |
76 let mclient = fromMaybe client $ find (== client) mclients |
77 |
77 |
78 clientsIn <- sendAnswers answers mclient mclients mrooms |
78 clientsIn <- sendAnswers answers mclient mclients mrooms |
79 |
79 |
80 mainLoop servSock acceptChan clientsIn mrooms |
80 when ((isDedicated globalOptions) || (not $ null clientsIn)) $ mainLoop servSock acceptChan clientsIn mrooms |
81 |
81 |
82 |
82 |
83 startServer serverSocket = do |
83 startServer serverSocket = do |
84 acceptChan <- atomically newTChan |
84 acceptChan <- atomically newTChan |
85 forkIO $ acceptLoop serverSocket acceptChan |
85 forkIO $ acceptLoop serverSocket acceptChan |