1 {-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-} |
|
2 |
|
3 module Main where |
|
4 |
|
5 import qualified Network |
|
6 import Network.Socket |
|
7 import IO |
|
8 import System.IO |
|
9 import Control.Concurrent |
|
10 import Control.Concurrent.STM |
|
11 import Control.Exception (handle, finally, Exception, IOException) |
|
12 import Control.Monad |
|
13 import Maybe (fromMaybe, isJust, fromJust) |
|
14 import Data.List |
|
15 import Miscutils |
|
16 import HWProto |
|
17 import Opts |
|
18 import Data.Time |
|
19 |
|
20 #if !defined(mingw32_HOST_OS) |
|
21 import System.Posix |
|
22 #endif |
|
23 |
|
24 |
|
25 data Messages = |
|
26 Accept ClientInfo |
|
27 | ClientMessage ([String], ClientInfo) |
|
28 | CoreMessage [String] |
|
29 | TimerTick |
|
30 |
|
31 messagesLoop :: TChan [String] -> IO() |
|
32 messagesLoop messagesChan = forever $ do |
|
33 threadDelay (25 * 10^6) -- 25 seconds |
|
34 atomically $ writeTChan messagesChan ["PING"] |
|
35 |
|
36 timerLoop :: TChan [String] -> IO() |
|
37 timerLoop messagesChan = forever $ do |
|
38 threadDelay (60 * 10^6) -- 60 seconds |
|
39 atomically $ writeTChan messagesChan ["MINUTELY"] |
|
40 |
|
41 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
|
42 acceptLoop servSock acceptChan = |
|
43 Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
|
44 do |
|
45 (cHandle, host, _) <- Network.accept servSock |
|
46 |
|
47 currentTime <- getCurrentTime |
|
48 putStrLn $ (show currentTime) ++ " new client: " ++ host |
|
49 |
|
50 cChan <- atomically newTChan |
|
51 sendChan <- atomically newTChan |
|
52 forkIO $ clientRecvLoop cHandle cChan |
|
53 forkIO $ clientSendLoop cHandle cChan sendChan |
|
54 |
|
55 atomically $ writeTChan acceptChan |
|
56 (ClientInfo |
|
57 cChan |
|
58 sendChan |
|
59 cHandle |
|
60 host |
|
61 currentTime |
|
62 "" |
|
63 0 |
|
64 "" |
|
65 False |
|
66 False |
|
67 False |
|
68 False) |
|
69 |
|
70 atomically $ writeTChan cChan ["ASKME"] |
|
71 acceptLoop servSock acceptChan |
|
72 |
|
73 |
|
74 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
|
75 listenLoop handle buf chan = do |
|
76 str <- hGetLine handle |
|
77 if str == "" then do |
|
78 atomically $ writeTChan chan buf |
|
79 listenLoop handle [] chan |
|
80 else |
|
81 listenLoop handle (buf ++ [str]) chan |
|
82 |
|
83 |
|
84 clientRecvLoop :: Handle -> TChan [String] -> IO () |
|
85 clientRecvLoop handle chan = |
|
86 listenLoop handle [] chan |
|
87 `catch` (\e -> (clientOff $ show e) >> return ()) |
|
88 where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message |
|
89 |
|
90 clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO() |
|
91 clientSendLoop handle clChan chan = do |
|
92 answer <- atomically $ readTChan chan |
|
93 doClose <- Control.Exception.handle |
|
94 (\(e :: Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
|
95 forM_ answer (\str -> hPutStrLn handle str) |
|
96 hPutStrLn handle "" |
|
97 hFlush handle |
|
98 return $ isQuit answer |
|
99 |
|
100 if doClose then |
|
101 Control.Exception.handle (\(_ :: Exception) -> putStrLn "error on hClose") $ hClose handle |
|
102 else |
|
103 clientSendLoop handle clChan chan |
|
104 |
|
105 where |
|
106 sendQuit e = atomically $ writeTChan clChan ["QUIT", show e] |
|
107 isQuit answer = head answer == "BYE" |
|
108 |
|
109 sendAnswers [] _ clients _ = return clients |
|
110 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
|
111 let recipients = handlesFunc client clients rooms |
|
112 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
|
113 when (head answer == "NICK") $ putStrLn (show answer) |
|
114 |
|
115 clHandles' <- forM recipients $ |
|
116 \ch -> |
|
117 do |
|
118 atomically $ writeTChan (sendChan ch) answer |
|
119 if head answer == "BYE" then return [ch] else return [] |
|
120 |
|
121 let outHandles = concat clHandles' |
|
122 unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer)) |
|
123 |
|
124 let mclients = clients \\ outHandles |
|
125 |
|
126 sendAnswers answers client mclients rooms |
|
127 |
|
128 |
|
129 reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
|
130 reactCmd serverInfo cmd client clients rooms = do |
|
131 --putStrLn ("> " ++ show cmd) |
|
132 |
|
133 let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd |
|
134 let mrooms = roomsFunc rooms |
|
135 let mclients = (clientsFunc clients) |
|
136 let mclient = fromMaybe client $ find (== client) mclients |
|
137 let answers = map (\x -> x serverInfo) answerFuncs |
|
138 |
|
139 clientsIn <- sendAnswers answers mclient mclients mrooms |
|
140 mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn |
|
141 |
|
142 let clientsFinal = map (\cl -> if partRoom cl then cl{room = [], partRoom = False} else cl) clientsIn |
|
143 return (clientsFinal, mrooms) |
|
144 |
|
145 |
|
146 mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
|
147 mainLoop serverInfo acceptChan messagesChan clients rooms = do |
|
148 r <- atomically $ |
|
149 (Accept `fmap` readTChan acceptChan) `orElse` |
|
150 (ClientMessage `fmap` tselect clients) `orElse` |
|
151 (CoreMessage `fmap` readTChan messagesChan) |
|
152 |
|
153 case r of |
|
154 Accept ci -> do |
|
155 let sameHostClients = filter (\cl -> host ci == host cl) clients |
|
156 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
|
157 |
|
158 when haveJustConnected $ do |
|
159 atomically $ do |
|
160 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
|
161 |
|
162 currentTime <- getCurrentTime |
|
163 let newServerInfo = serverInfo{ |
|
164 loginsNumber = loginsNumber serverInfo + 1, |
|
165 lastHourUsers = currentTime : lastHourUsers serverInfo |
|
166 } |
|
167 mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms |
|
168 |
|
169 ClientMessage (cmd, client) -> do |
|
170 (clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms |
|
171 |
|
172 let hadRooms = (not $ null rooms) && (null mrooms) |
|
173 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
|
174 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
|
175 |
|
176 CoreMessage msg -> case msg of |
|
177 ["PING"] -> |
|
178 if not $ null $ clients then |
|
179 do |
|
180 let client = head clients -- don't care |
|
181 (clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms |
|
182 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
|
183 else |
|
184 mainLoop serverInfo acceptChan messagesChan clients rooms |
|
185 ["MINUTELY"] -> do |
|
186 currentTime <- getCurrentTime |
|
187 let newServerInfo = serverInfo{ |
|
188 lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo |
|
189 } |
|
190 atomically $ swapTMVar |
|
191 (stats serverInfo) |
|
192 (StatisticsInfo |
|
193 (length clients) |
|
194 (length rooms) |
|
195 ) |
|
196 mainLoop newServerInfo acceptChan messagesChan clients rooms |
|
197 |
|
198 startServer :: ServerInfo -> Socket -> IO() |
|
199 startServer serverInfo serverSocket = do |
|
200 acceptChan <- atomically newTChan |
|
201 forkIO $ acceptLoop serverSocket acceptChan |
|
202 |
|
203 messagesChan <- atomically newTChan |
|
204 forkIO $ messagesLoop messagesChan |
|
205 forkIO $ timerLoop messagesChan |
|
206 |
|
207 mainLoop serverInfo acceptChan messagesChan [] [] |
|
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 |
|
223 |
|
224 main = withSocketsDo $ do |
|
225 #if !defined(mingw32_HOST_OS) |
|
226 installHandler sigPIPE Ignore Nothing; |
|
227 #endif |
|
228 |
|
229 stats <- atomically $ newTMVar (StatisticsInfo 0 0) |
|
230 serverInfo <- getOpts $ newServerInfo stats |
|
231 |
|
232 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
|
233 serverSocket <- Network.listenOn $ Network.PortNumber (listenPort serverInfo) |
|
234 |
|
235 startUDPserver stats |
|
236 startServer serverInfo serverSocket `finally` sClose serverSocket |
|