2 module Actions where |
2 module Actions where |
3 |
3 |
4 import Control.Concurrent |
4 import Control.Concurrent |
5 import qualified Data.Set as Set |
5 import qualified Data.Set as Set |
6 import qualified Data.Sequence as Seq |
6 import qualified Data.Sequence as Seq |
|
7 import qualified Data.List as L |
7 import System.Log.Logger |
8 import System.Log.Logger |
8 import Control.Monad |
9 import Control.Monad |
9 import Data.Time |
10 import Data.Time |
10 import Data.Maybe |
11 import Data.Maybe |
11 import Control.Monad.Reader |
12 import Control.Monad.Reader |
53 | AddClient ClientInfo |
54 | AddClient ClientInfo |
54 | DeleteClient ClientIndex |
55 | DeleteClient ClientIndex |
55 | PingAll |
56 | PingAll |
56 | StatsAction |
57 | StatsAction |
57 | RestartServer Bool |
58 | RestartServer Bool |
|
59 | AddNick2Bans B.ByteString B.ByteString UTCTime |
|
60 | AddIP2Bans B.ByteString B.ByteString UTCTime |
|
61 | CheckBanned |
58 |
62 |
59 |
63 |
60 type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] |
64 type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] |
61 |
65 |
62 instance NFData Action where |
66 instance NFData Action where |
372 modify (\s -> s{clientIndex = Just banId}) |
376 modify (\s -> s{clientIndex = Just banId}) |
373 clHost <- client's host |
377 clHost <- client's host |
374 currentTime <- io getCurrentTime |
378 currentTime <- io getCurrentTime |
375 let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")" |
379 let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")" |
376 mapM_ processAction [ |
380 mapM_ processAction [ |
377 ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds currentTime, msg)) : lastLogins s}) |
381 AddIP2Bans clHost msg (addUTCTime seconds currentTime) |
378 , KickClient banId |
382 , KickClient banId |
379 ] |
383 ] |
380 |
384 |
381 |
385 |
382 processAction (KickRoomClient kickId) = do |
386 processAction (KickRoomClient kickId) = do |
396 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl)) |
400 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl)) |
397 |
401 |
398 return ci |
402 return ci |
399 |
403 |
400 modify (\s -> s{clientIndex = Just newClId}) |
404 modify (\s -> s{clientIndex = Just newClId}) |
401 processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion] |
405 mapM_ processAction |
402 |
406 [ |
403 let newLogins = takeWhile (\(_ , (time, _)) -> connectTime cl `diffUTCTime` time <= 0) $ lastLogins si |
407 AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion] |
404 let info = host cl `Prelude.lookup` newLogins |
408 , CheckBanned |
405 if isJust info then |
409 , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl) |
406 mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd . fromJust $ info)] |
410 ] |
407 else |
411 |
408 processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins}) |
412 |
409 |
413 processAction (AddNick2Bans n reason expiring) = do |
|
414 processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s}) |
|
415 |
|
416 processAction (AddIP2Bans ip reason expiring) = do |
|
417 processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s}) |
|
418 |
|
419 processAction CheckBanned = do |
|
420 clTime <- client's connectTime |
|
421 clNick <- client's nick |
|
422 clHost <- client's host |
|
423 si <- gets serverInfo |
|
424 let validBans = filter (checkNotExpired clTime) $ bans si |
|
425 let ban = L.find (checkBan clHost clNick) $ validBans |
|
426 when (isJust ban) $ |
|
427 mapM_ processAction [ |
|
428 ModifyServerInfo (\s -> s{bans = validBans}) |
|
429 , ByeClient (getBanReason $ fromJust ban) |
|
430 ] |
|
431 where |
|
432 checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0 |
|
433 checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0 |
|
434 checkBan ip _ (BanByIP bip _ _) = bip == ip |
|
435 checkBan _ n (BanByNick bn _ _) = bn == n |
|
436 getBanReason (BanByIP _ msg _) = msg |
|
437 getBanReason (BanByNick _ msg _) = msg |
410 |
438 |
411 processAction PingAll = do |
439 processAction PingAll = do |
412 rnc <- gets roomsClients |
440 rnc <- gets roomsClients |
413 io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) |
441 io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) |
414 cis <- io $ allClientsM rnc |
442 cis <- io $ allClientsM rnc |