30 import ServerState |
30 import ServerState |
31 import Consts |
31 import Consts |
32 import ConfigFile |
32 import ConfigFile |
33 import EngineInteraction |
33 import EngineInteraction |
34 |
34 |
35 data Action = |
|
36 AnswerClients ![ClientChan] ![B.ByteString] |
|
37 | SendServerMessage |
|
38 | SendServerVars |
|
39 | MoveToRoom RoomIndex |
|
40 | MoveToLobby B.ByteString |
|
41 | RemoveTeam B.ByteString |
|
42 | SendTeamRemovalMessage B.ByteString |
|
43 | RemoveRoom |
|
44 | FinishGame |
|
45 | UnreadyRoomClients |
|
46 | JoinLobby |
|
47 | ProtocolError B.ByteString |
|
48 | Warning B.ByteString |
|
49 | NoticeMessage Notice |
|
50 | ByeClient B.ByteString |
|
51 | KickClient ClientIndex |
|
52 | KickRoomClient ClientIndex |
|
53 | BanClient NominalDiffTime B.ByteString ClientIndex |
|
54 | BanIP B.ByteString NominalDiffTime B.ByteString |
|
55 | BanNick B.ByteString NominalDiffTime B.ByteString |
|
56 | BanList |
|
57 | Unban B.ByteString |
|
58 | ChangeMaster (Maybe ClientIndex) |
|
59 | RemoveClientTeams |
|
60 | ModifyClient (ClientInfo -> ClientInfo) |
|
61 | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) |
|
62 | ModifyRoomClients (ClientInfo -> ClientInfo) |
|
63 | ModifyRoom (RoomInfo -> RoomInfo) |
|
64 | ModifyServerInfo (ServerInfo -> ServerInfo) |
|
65 | AddRoom B.ByteString B.ByteString |
|
66 | SendUpdateOnThisRoom |
|
67 | CheckRegistered |
|
68 | ClearAccountsCache |
|
69 | ProcessAccountInfo AccountInfo |
|
70 | AddClient ClientInfo |
|
71 | DeleteClient ClientIndex |
|
72 | PingAll |
|
73 | StatsAction |
|
74 | RestartServer |
|
75 | AddNick2Bans B.ByteString B.ByteString UTCTime |
|
76 | AddIP2Bans B.ByteString B.ByteString UTCTime |
|
77 | CheckBanned Bool |
|
78 | SaveReplay |
|
79 | Stats |
|
80 |
|
81 |
35 |
82 type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] |
36 type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] |
83 |
|
84 instance NFData Action where |
|
85 rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` () |
|
86 rnf a = a `seq` () |
|
87 |
|
88 --instance NFData B.ByteString |
|
89 instance NFData (Chan a) |
|
90 |
37 |
91 |
38 |
92 othersChans :: StateT ServerState IO [ClientChan] |
39 othersChans :: StateT ServerState IO [ClientChan] |
93 othersChans = do |
40 othersChans = do |
94 cl <- client's id |
41 cl <- client's id |
212 processAction (MoveToRoom ri) = do |
159 processAction (MoveToRoom ri) = do |
213 (Just ci) <- gets clientIndex |
160 (Just ci) <- gets clientIndex |
214 rnc <- gets roomsClients |
161 rnc <- gets roomsClients |
215 |
162 |
216 io $ do |
163 io $ do |
217 modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False, isInGame = False}) ci |
164 modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False, isInGame = False, clientClan = Nothing}) ci |
218 modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri |
165 modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri |
219 moveClientToRoom rnc ri ci |
166 moveClientToRoom rnc ri ci |
220 |
167 |
221 chans <- liftM (map sendChan) $ roomClientsS ri |
168 chans <- liftM (map sendChan) $ roomClientsS ri |
222 clNick <- client's nick |
169 clNick <- client's nick |
428 p <- client's clientProto |
375 p <- client's clientProto |
429 checker <- client's isChecker |
376 checker <- client's isChecker |
430 uid <- client's clUID |
377 uid <- client's clUID |
431 -- allow multiple checker logins |
378 -- allow multiple checker logins |
432 haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS |
379 haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS |
433 if haveSameNick && (not checker) then |
380 if (not checker) && haveSameNick then |
434 if p < 38 then |
381 if p < 38 then |
435 processAction $ ByeClient $ loc "Nickname is already in use" |
382 processAction $ ByeClient $ loc "Nickname is already in use" |
436 else |
383 else |
437 processAction $ NoticeMessage NickAlreadyInUse |
384 processAction $ NoticeMessage NickAlreadyInUse |
438 else |
385 else |
453 b <- isBanned |
400 b <- isBanned |
454 c <- client's isChecker |
401 c <- client's isChecker |
455 when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin |
402 when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin |
456 Guest -> do |
403 Guest -> do |
457 b <- isBanned |
404 b <- isBanned |
|
405 c <- client's isChecker |
458 when (not b) $ |
406 when (not b) $ |
459 processAction JoinLobby |
407 if c then |
|
408 checkerLogin "" False |
|
409 else |
|
410 processAction JoinLobby |
460 Admin -> do |
411 Admin -> do |
461 mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
412 mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
462 chan <- client's sendChan |
413 chan <- client's sendChan |
463 processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] |
414 processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] |
464 where |
415 where |
586 (Just ci) <- gets clientIndex |
537 (Just ci) <- gets clientIndex |
587 rc <- gets removedClients |
538 rc <- gets removedClients |
588 when (not $ ci `Set.member` rc) |
539 when (not $ ci `Set.member` rc) |
589 $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s}) |
540 $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s}) |
590 |
541 |
|
542 |
591 processAction (CheckBanned byIP) = do |
543 processAction (CheckBanned byIP) = do |
592 clTime <- client's connectTime |
544 clTime <- client's connectTime |
593 clNick <- client's nick |
545 clNick <- client's nick |
594 clHost <- client's host |
546 clHost <- client's host |
595 si <- gets serverInfo |
547 si <- gets serverInfo |
604 checkBan True ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip |
556 checkBan True ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip |
605 checkBan False _ n (BanByNick bn _ _) = caseInsensitiveCompare bn n |
557 checkBan False _ n (BanByNick bn _ _) = caseInsensitiveCompare bn n |
606 checkBan _ _ _ _ = False |
558 checkBan _ _ _ _ = False |
607 getBanReason (BanByIP _ msg _) = msg |
559 getBanReason (BanByIP _ msg _) = msg |
608 getBanReason (BanByNick _ msg _) = msg |
560 getBanReason (BanByNick _ msg _) = msg |
|
561 |
609 |
562 |
610 processAction PingAll = do |
563 processAction PingAll = do |
611 rnc <- gets roomsClients |
564 rnc <- gets roomsClients |
612 io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) |
565 io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) |
613 cis <- io $ allClientsM rnc |
566 cis <- io $ allClientsM rnc |
646 return () |
599 return () |
647 processAction $ ModifyServerInfo (\s -> s{shutdownPending = True}) |
600 processAction $ ModifyServerInfo (\s -> s{shutdownPending = True}) |
648 |
601 |
649 processAction Stats = do |
602 processAction Stats = do |
650 cls <- allClientsS |
603 cls <- allClientsS |
651 let stats = versions cls |
604 rms <- allRoomsS |
652 processAction $ Warning stats |
605 let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls |
653 where |
606 let roomsMap = Map.fromListWith (+) . map (\c -> (roomProto c, 1 :: Int)) . filter ((/=) 0 . roomProto) $ rms |
654 versions = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"]) |
607 let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap |
655 . concatMap (\(p, n :: Int) -> ["<tr><td>", protoNumber2ver p, "</td><td>", showB n, "</td></tr>"]) |
608 let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"]) |
656 . Map.toList . Map.fromListWith (+) . map (\c -> (clientProto c, 1)) |
609 . concatMap (\p -> [ |
|
610 "<tr><td>", protoNumber2ver p |
|
611 , "</td><td>", showB $ Map.findWithDefault 0 p clientsMap |
|
612 , "</td><td>", showB $ Map.findWithDefault 0 p roomsMap |
|
613 , "</td></tr>"]) |
|
614 . Set.toList $ keys |
|
615 processAction $ Warning versionsStats |
|
616 |
657 |
617 |
658 #if defined(OFFICIAL_SERVER) |
618 #if defined(OFFICIAL_SERVER) |
659 processAction SaveReplay = do |
619 processAction SaveReplay = do |
660 ri <- clientRoomA |
620 ri <- clientRoomA |
661 rnc <- gets roomsClients |
621 rnc <- gets roomsClients |
662 |
622 |
663 io $ do |
623 io $ do |
664 r <- room'sM rnc id ri |
624 r <- room'sM rnc id ri |
665 saveReplay r |
625 saveReplay r |
|
626 |
|
627 |
|
628 processAction CheckRecord = do |
|
629 p <- client's clientProto |
|
630 c <- client's sendChan |
|
631 (cinfo, l) <- io $ loadReplay (fromIntegral p) |
|
632 when (not . null $ l) $ |
|
633 mapM_ processAction [ |
|
634 AnswerClients [c] ("REPLAY" : l) |
|
635 , ModifyClient $ \c -> c{checkInfo = cinfo} |
|
636 ] |
|
637 |
|
638 processAction (CheckFailed msg) = do |
|
639 Just (CheckInfo fileName _) <- client's checkInfo |
|
640 io $ moveFailedRecord fileName |
|
641 |
|
642 processAction (CheckSuccess info) = do |
|
643 Just (CheckInfo fileName _) <- client's checkInfo |
|
644 io $ moveCheckedRecord fileName |
|
645 |
666 #else |
646 #else |
667 processAction SaveReplay = return () |
647 processAction SaveReplay = return () |
|
648 processAction CheckRecord = return () |
|
649 processAction (CheckFailed _) = return () |
|
650 processAction (CheckSuccess _) = return () |
668 #endif |
651 #endif |