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, when, unless) |
9 import Control.Monad (forM, forM_, filterM, liftM, when, unless) |
10 import Maybe (fromMaybe) |
10 import Maybe (fromMaybe, isJust, fromJust) |
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 |
18 (cHandle, host, port) <- accept servSock |
18 (cHandle, host, port) <- accept servSock |
19 hPutStrLn cHandle "CONNECTED\n" |
19 hPutStrLn cHandle "CONNECTED\n" |
20 hFlush cHandle |
20 hFlush cHandle |
21 cChan <- atomically newTChan |
21 cChan <- atomically newTChan |
22 forkIO $ clientLoop cHandle cChan |
22 forkIO $ clientLoop cHandle cChan |
23 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
23 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False) |
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 |
59 sendAnswers answers client mclients rooms |
59 sendAnswers answers client mclients rooms |
60 where |
60 where |
61 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
61 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
62 |
62 |
63 |
63 |
|
64 reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
|
65 reactCmd cmd client clients rooms = do |
|
66 putStrLn ("> " ++ show cmd) |
|
67 |
|
68 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
|
69 let mrooms = roomsFunc rooms |
|
70 let mclients = (clientsFunc clients) |
|
71 let mclient = fromMaybe client $ find (== client) mclients |
|
72 |
|
73 clientsIn <- sendAnswers answers mclient mclients mrooms |
|
74 let quitClient = find forceQuit $ clientsIn |
|
75 if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) |
|
76 |
|
77 |
64 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
78 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
65 mainLoop servSock acceptChan clients rooms = do |
79 mainLoop servSock acceptChan clients rooms = do |
66 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
80 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
67 case r of |
81 case r of |
68 Left ci -> do |
82 Left ci -> do |
69 mainLoop servSock acceptChan (clients ++ [ci]) rooms |
83 mainLoop servSock acceptChan (clients ++ [ci]) rooms |
70 Right (cmd, client) -> do |
84 Right (cmd, client) -> do |
71 putStrLn ("> " ++ show cmd) |
85 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
72 |
|
73 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
|
74 let mrooms = roomsFunc rooms |
|
75 let mclients = (clientsFunc clients) |
|
76 let mclient = fromMaybe client $ find (== client) mclients |
|
77 |
|
78 clientsIn <- sendAnswers answers mclient mclients mrooms |
|
79 |
86 |
80 let hadRooms = (not $ null rooms) && (null mrooms) |
87 let hadRooms = (not $ null rooms) && (null mrooms) |
81 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
88 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
82 mainLoop servSock acceptChan clientsIn mrooms |
89 mainLoop servSock acceptChan clientsIn mrooms |
83 |
90 |