20 |
20 |
21 data Messages = |
21 data Messages = |
22 Accept ClientInfo |
22 Accept ClientInfo |
23 | ClientMessage ([String], ClientInfo) |
23 | ClientMessage ([String], ClientInfo) |
24 | CoreMessage [String] |
24 | CoreMessage [String] |
|
25 | TimerTick |
25 |
26 |
26 messagesLoop :: TChan [String] -> IO() |
27 messagesLoop :: TChan [String] -> IO() |
27 messagesLoop messagesChan = forever $ do |
28 messagesLoop messagesChan = forever $ do |
28 threadDelay (30 * 10^6) -- 30 seconds |
29 threadDelay (25 * 10^6) -- 25 seconds |
29 atomically $ writeTChan messagesChan ["PING"] |
30 atomically $ writeTChan messagesChan ["PING"] |
|
31 |
|
32 timerLoop :: TChan [String] -> IO() |
|
33 timerLoop messagesChan = forever $ do |
|
34 threadDelay (60 * 10^6) -- 60 seconds |
|
35 atomically $ writeTChan messagesChan ["MINUTELY"] |
30 |
36 |
31 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
37 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
32 acceptLoop servSock acceptChan = |
38 acceptLoop servSock acceptChan = |
33 Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
39 Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
34 do |
40 do |
121 |
127 |
122 when haveJustConnected $ do |
128 when haveJustConnected $ do |
123 atomically $ do |
129 atomically $ do |
124 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
130 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
125 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
131 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
126 |
132 |
127 mainLoop serverInfo acceptChan messagesChan (clients ++ [ci]) rooms |
133 currentTime <- getCurrentTime |
|
134 let newServerInfo = serverInfo{ |
|
135 loginsNumber = loginsNumber serverInfo + 1, |
|
136 lastHourUsers = currentTime : lastHourUsers serverInfo |
|
137 } |
|
138 mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms |
128 |
139 |
129 ClientMessage (cmd, client) -> do |
140 ClientMessage (cmd, client) -> do |
130 (clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms |
141 (clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms |
131 |
142 |
132 let hadRooms = (not $ null rooms) && (null mrooms) |
143 let hadRooms = (not $ null rooms) && (null mrooms) |
133 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
144 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
134 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
145 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
135 |
146 |
136 CoreMessage msg -> |
147 CoreMessage msg -> case msg of |
137 if not $ null $ clients then |
148 ["PING"] -> |
138 do |
149 if not $ null $ clients then |
139 let client = head clients -- don't care |
150 do |
140 (clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms |
151 let client = head clients -- don't care |
141 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
152 (clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms |
142 else |
153 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
143 mainLoop serverInfo acceptChan messagesChan clients rooms |
154 else |
|
155 mainLoop serverInfo acceptChan messagesChan clients rooms |
|
156 ["MINUTELY"] -> do |
|
157 currentTime <- getCurrentTime |
|
158 let newServerInfo = serverInfo{ |
|
159 lastHourUsers = filter (\t -> currentTime `diffUTCTime` t > 3600) $ lastHourUsers serverInfo |
|
160 } |
|
161 mainLoop newServerInfo acceptChan messagesChan clients rooms |
144 |
162 |
145 startServer :: ServerInfo -> Socket -> IO() |
163 startServer :: ServerInfo -> Socket -> IO() |
146 startServer serverInfo serverSocket = do |
164 startServer serverInfo serverSocket = do |
147 acceptChan <- atomically newTChan |
165 acceptChan <- atomically newTChan |
148 forkIO $ acceptLoop serverSocket acceptChan |
166 forkIO $ acceptLoop serverSocket acceptChan |
149 |
167 |
150 messagesChan <- atomically newTChan |
168 messagesChan <- atomically newTChan |
151 forkIO $ messagesLoop messagesChan |
169 forkIO $ messagesLoop messagesChan |
|
170 forkIO $ timerLoop messagesChan |
152 |
171 |
153 mainLoop serverInfo acceptChan messagesChan [] [] |
172 mainLoop serverInfo acceptChan messagesChan [] [] |
154 |
173 |
155 |
174 |
156 main = withSocketsDo $ do |
175 main = withSocketsDo $ do |
157 #if !defined(mingw32_HOST_OS) |
176 #if !defined(mingw32_HOST_OS) |
158 installHandler sigPIPE Ignore Nothing; |
177 installHandler sigPIPE Ignore Nothing; |
159 #endif |
178 #endif |
160 serverInfo <- getOpts newServerInfo |
179 serverInfo <- getOpts $ newServerInfo |
161 |
180 |
162 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
181 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
|
182 serverSocket <- listenOn $ PortNumber (listenPort serverInfo) |
163 |
183 |
164 serverSocket <- listenOn $ PortNumber (listenPort serverInfo) |
|
165 startServer serverInfo serverSocket `finally` sClose serverSocket |
184 startServer serverInfo serverSocket `finally` sClose serverSocket |