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, when, unless) |
9 import Control.Monad |
10 import Maybe (fromMaybe, isJust, fromJust) |
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 |
16 #if !defined(mingw32_HOST_OS) |
16 #if !defined(mingw32_HOST_OS) |
17 import System.Posix |
17 import System.Posix |
18 #endif |
18 #endif |
19 |
19 |
|
20 data Messages = |
|
21 Accept ClientInfo |
|
22 | ClientMessage ([String], ClientInfo) |
|
23 | CoreMessage [String] |
|
24 |
|
25 messagesLoop :: TChan [String] -> IO() |
|
26 messagesLoop messagesChan = forever $ do |
|
27 threadDelay (30 * 10^6) -- 30 seconds |
|
28 atomically $ writeTChan messagesChan ["PING"] |
20 |
29 |
21 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
30 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
22 acceptLoop servSock acceptChan = do |
31 acceptLoop servSock acceptChan = do |
23 (cHandle, host, port) <- accept servSock |
32 (cHandle, host, port) <- accept servSock |
24 hPutStrLn cHandle "CONNECTED\n" |
33 hPutStrLn cHandle "CONNECTED\n" |
78 clientsIn <- sendAnswers answers mclient mclients mrooms |
87 clientsIn <- sendAnswers answers mclient mclients mrooms |
79 let quitClient = find forceQuit $ clientsIn |
88 let quitClient = find forceQuit $ clientsIn |
80 if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) |
89 if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) |
81 |
90 |
82 |
91 |
83 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
92 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
84 mainLoop servSock acceptChan clients rooms = do |
93 mainLoop servSock acceptChan messagesChan clients rooms = do |
85 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
94 r <- atomically $ (Accept `fmap` readTChan acceptChan) `orElse` (ClientMessage `fmap` tselect clients) `orElse` (CoreMessage `fmap` readTChan messagesChan) |
86 case r of |
95 case r of |
87 Left ci -> do |
96 Accept ci -> |
88 mainLoop servSock acceptChan (clients ++ [ci]) rooms |
97 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
89 Right (cmd, client) -> do |
98 ClientMessage (cmd, client) -> do |
90 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
99 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
91 |
100 |
92 let hadRooms = (not $ null rooms) && (null mrooms) |
101 let hadRooms = (not $ null rooms) && (null mrooms) |
93 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
102 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
94 mainLoop servSock acceptChan clientsIn mrooms |
103 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
|
104 CoreMessage msg -> if not $ null $ clients then |
|
105 do |
|
106 let client = head clients -- don't care |
|
107 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
|
108 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
|
109 else |
|
110 mainLoop servSock acceptChan messagesChan clients rooms |
95 |
111 |
96 |
112 |
97 startServer serverSocket = do |
113 startServer serverSocket = do |
98 acceptChan <- atomically newTChan |
114 acceptChan <- atomically newTChan |
99 forkIO $ acceptLoop serverSocket acceptChan |
115 forkIO $ acceptLoop serverSocket acceptChan |
100 mainLoop serverSocket acceptChan [] [] |
116 |
|
117 messagesChan <- atomically newTChan |
|
118 forkIO $ messagesLoop messagesChan |
|
119 |
|
120 mainLoop serverSocket acceptChan messagesChan [] [] |
101 |
121 |
102 |
122 |
103 main = withSocketsDo $ do |
123 main = withSocketsDo $ do |
104 #if !defined(mingw32_HOST_OS) |
124 #if !defined(mingw32_HOST_OS) |
105 installHandler sigPIPE Ignore Nothing; |
125 installHandler sigPIPE Ignore Nothing; |