1 {-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-} |
1 {-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-} |
2 |
2 |
3 module Main where |
3 module Main where |
4 |
4 |
5 import Network |
5 import qualified Network |
|
6 import Network.Socket |
6 import IO |
7 import IO |
7 import System.IO |
8 import System.IO |
8 import Control.Concurrent |
9 import Control.Concurrent |
9 import Control.Concurrent.STM |
10 import Control.Concurrent.STM |
10 import Control.Exception (handle, finally, Exception, IOException) |
11 import Control.Exception (handle, finally, Exception, IOException) |
39 |
40 |
40 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
41 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
41 acceptLoop servSock acceptChan = |
42 acceptLoop servSock acceptChan = |
42 Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
43 Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
43 do |
44 do |
44 (cHandle, host, _) <- accept servSock |
45 (cHandle, host, _) <- Network.accept servSock |
45 |
46 |
46 currentTime <- getCurrentTime |
47 currentTime <- getCurrentTime |
47 putStrLn $ (show currentTime) ++ " new client: " ++ host |
48 putStrLn $ (show currentTime) ++ " new client: " ++ host |
48 |
49 |
49 cChan <- atomically newTChan |
50 cChan <- atomically newTChan |
184 ["MINUTELY"] -> do |
185 ["MINUTELY"] -> do |
185 currentTime <- getCurrentTime |
186 currentTime <- getCurrentTime |
186 let newServerInfo = serverInfo{ |
187 let newServerInfo = serverInfo{ |
187 lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo |
188 lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo |
188 } |
189 } |
|
190 atomically $ swapTMVar |
|
191 (stats serverInfo) |
|
192 (StatisticsInfo |
|
193 (length clients) |
|
194 (length rooms) |
|
195 ) |
189 mainLoop newServerInfo acceptChan messagesChan clients rooms |
196 mainLoop newServerInfo acceptChan messagesChan clients rooms |
190 |
197 |
191 startServer :: ServerInfo -> Socket -> IO() |
198 startServer :: ServerInfo -> Socket -> IO() |
192 startServer serverInfo serverSocket = do |
199 startServer serverInfo serverSocket = do |
193 acceptChan <- atomically newTChan |
200 acceptChan <- atomically newTChan |
197 forkIO $ messagesLoop messagesChan |
204 forkIO $ messagesLoop messagesChan |
198 forkIO $ timerLoop messagesChan |
205 forkIO $ timerLoop messagesChan |
199 |
206 |
200 mainLoop serverInfo acceptChan messagesChan [] [] |
207 mainLoop serverInfo acceptChan messagesChan [] [] |
201 |
208 |
|
209 socketEcho :: Socket -> TMVar StatisticsInfo -> IO () |
|
210 socketEcho sock stats = do |
|
211 (msg, recv_count, client) <- recvFrom sock 128 |
|
212 currStats <- atomically $ readTMVar stats |
|
213 send_count <- sendTo sock (statsMsg1 currStats) client |
|
214 socketEcho sock stats |
|
215 where |
|
216 statsMsg1 currStats = (show $ playersNumber currStats) ++ "," ++ (show $ roomsNumber currStats) |
|
217 |
|
218 startUDPserver :: TMVar StatisticsInfo -> IO ThreadId |
|
219 startUDPserver stats = do |
|
220 sock <- socket AF_INET Datagram 0 |
|
221 bindSocket sock (SockAddrInet 46632 iNADDR_ANY) |
|
222 forkIO $ socketEcho sock stats |
202 |
223 |
203 main = withSocketsDo $ do |
224 main = withSocketsDo $ do |
204 #if !defined(mingw32_HOST_OS) |
225 #if !defined(mingw32_HOST_OS) |
205 installHandler sigPIPE Ignore Nothing; |
226 installHandler sigPIPE Ignore Nothing; |
206 #endif |
227 #endif |
207 serverInfo <- getOpts $ newServerInfo |
228 |
|
229 stats <- atomically $ newTMVar (StatisticsInfo 0 0) |
|
230 serverInfo <- getOpts $ newServerInfo stats |
208 |
231 |
209 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
232 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
210 serverSocket <- listenOn $ PortNumber (listenPort serverInfo) |
233 serverSocket <- Network.listenOn $ Network.PortNumber (listenPort serverInfo) |
211 |
234 |
|
235 startUDPserver stats |
212 startServer serverInfo serverSocket `finally` sClose serverSocket |
236 startServer serverInfo serverSocket `finally` sClose serverSocket |