Clear gmSwitch before activating switcher
If if you pressed [Switch Hedgehog] key and THEN enabled the
Switch Hedgehog utility, you immediately switch. This was mildly
confusing.
{- * Hedgewars, a free turn based strategy game * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; version 2 of the License * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. \-}{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}{-# OPTIONS_GHC -fno-warn-orphans #-}module Actions whereimport Control.Concurrentimport qualified Data.Set as Setimport qualified Data.Map as Mapimport qualified Data.List as Limport qualified Control.Exception as Exceptionimport System.Log.Loggerimport Control.Monadimport Data.Timeimport Data.Maybeimport Control.Monad.Readerimport Control.Monad.State.Strictimport qualified Data.ByteString.Char8 as Bimport Control.DeepSeqimport Data.Uniqueimport Control.Arrowimport Control.Exception as Eimport System.Processimport Network.Socketimport System.Randomimport qualified Data.Traversable as DTimport Text.Regex.TDFAimport qualified Text.Regex.TDFA as TDFAimport qualified Text.Regex.TDFA.ByteString as TDFABimport qualified Data.Yaml as YAML-----------------------------#if defined(OFFICIAL_SERVER)import OfficialServer.GameReplayStore#endifimport CoreTypesimport Utilsimport ClientIOimport ServerStateimport Constsimport ConfigFileimport EngineInteractionimport FloodDetectionimport HWProtoCoreimport VotesothersChans :: StateT ServerState IO [ClientChan]othersChans = do cl <- client's id ri <- clientRoomA liftM (map sendChan . filter (/= cl)) $ roomClientsS riprocessAction :: Action -> StateT ServerState IO ()processAction (AnswerClients chans msg) = io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)processAction SendServerMessage = do chan <- client's sendChan protonum <- client's clientProto si <- liftM serverInfo get let message = if protonum < latestReleaseVersion si then serverMessageForOldVersions si else serverMessage si processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]processAction SendServerVars = do chan <- client's sendChan si <- gets serverInfo io $ writeChan chan ("SERVER_VARS" : vars si) where vars si = [ "MOTD_NEW", serverMessage si, "MOTD_OLD", serverMessageForOldVersions si, "LATEST_PROTO", showB $ latestReleaseVersion si ]processAction (ProtocolError msg) = do chan <- client's sendChan processAction $ AnswerClients [chan] ["ERROR", msg]processAction (Warning msg) = do chan <- client's sendChan processAction $ AnswerClients [chan] ["WARNING", msg]processAction (NoticeMessage n) = do chan <- client's sendChan processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]processAction (ByeClient msg) = do (Just ci) <- gets clientIndex ri <- clientRoomA chan <- client's sendChan clNick <- client's nick loggedIn <- client's isVisible when (ri /= lobbyId) $ do processAction $ (MoveToLobby msg) return () clientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS io $ infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg) when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] mapM_ processAction [ AnswerClients [chan] ["BYE", msg] , ModifyClient (\c -> c{nick = "", isVisible = False}) -- this will effectively hide client from others while he isn't deleted from list ] s <- get put $! s{removedClients = ci `Set.insert` removedClients s}processAction (DeleteClient ci) = do io $ debugM "Clients" $ "DeleteClient: " ++ show ci rnc <- gets roomsClients io $ removeClient rnc ci s <- get put $! s{removedClients = ci `Set.delete` removedClients s} sp <- gets (shutdownPending . serverInfo) cls <- allClientsS io $ when (sp && null cls) $ throwIO ShutdownExceptionprocessAction (ModifyClient f) = do (Just ci) <- gets clientIndex rnc <- gets roomsClients io $ modifyClient rnc f ci return ()processAction (ModifyClient2 ci f) = do rnc <- gets roomsClients io $ modifyClient rnc f ci return ()processAction (ModifyRoomClients f) = do rnc <- gets roomsClients ri <- clientRoomA roomClIDs <- io $ roomClientsIndicesM rnc ri io $ mapM_ (modifyClient rnc f) roomClIDsprocessAction (ModifyRoom f) = do rnc <- gets roomsClients ri <- clientRoomA io $ modifyRoom rnc f ri return ()processAction (ModifyServerInfo f) = do modify (\s -> s{serverInfo = f $ serverInfo s}) si <- gets serverInfo io $ writeServerConfig siprocessAction (MoveToRoom ri) = do (Just ci) <- gets clientIndex rnc <- gets roomsClients io $ do modifyClient rnc ( \cl -> cl{teamsInGame = 0 , isReady = False , isMaster = False , isInGame = False , isJoinedMidGame = False , clientClan = Nothing}) ci modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri moveClientToRoom rnc ri ci chans <- liftM (map sendChan) $ roomClientsS ri clNick <- client's nick allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS mapM_ processAction [ AnswerClients chans ["JOINED", clNick] , AnswerClients allClientsChans ["CLIENT_FLAGS", "+i", clNick] , RegisterEvent RoomJoin ]processAction (MoveToLobby msg) = do (Just ci) <- gets clientIndex ri <- clientRoomA rnc <- gets roomsClients playersNum <- io $ room'sM rnc playersIn ri specialRoom <- io $ room'sM rnc isSpecial ri master <- client's isMaster-- client <- client's id clNick <- client's nick chans <- othersChans if master then if (playersNum > 1) || specialRoom then mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]] else processAction RemoveRoom else mapM_ processAction [RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]] allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS processAction $ AnswerClients allClientsChans ["CLIENT_FLAGS", "-i", clNick] -- when not removing room ready <- client's isReady when (not master || playersNum > 1 || specialRoom) . io $ do modifyRoom rnc (\r -> r{ playersIn = playersIn r - 1, readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r }) ri moveClientToLobby rnc ciprocessAction (ChangeMaster delegateId)= do (Just ci) <- gets clientIndex proto <- client's clientProto ri <- clientRoomA rnc <- gets roomsClients specialRoom <- io $ room'sM rnc isSpecial ri newMasterId <- if specialRoom then return delegateId else liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc ri newMaster <- io $ client'sM rnc id `DT.mapM` newMasterId oldMasterId <- io $ room'sM rnc masterID ri oldRoomName <- io $ room'sM rnc name ri kicked <- client's isKickedFromServer thisRoomChans <- liftM (map sendChan) $ roomClientsS ri let newRoomName = if ((proto < 42) || kicked) && (not specialRoom) then maybeNick newMaster else oldRoomName when (isJust oldMasterId) $ do oldMasterNick <- io $ client'sM rnc nick (fromJust oldMasterId) mapM_ processAction [ ModifyClient2 (fromJust oldMasterId) (\c -> c{isMaster = False}) , AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMasterNick] ] when (isJust newMasterId) $ mapM_ processAction [ ModifyClient2 (fromJust newMasterId) (\c -> c{isMaster = True}) , AnswerClients [sendChan $ fromJust newMaster] ["ROOM_CONTROL_ACCESS", "1"] , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick $ fromJust newMaster] -- TODO: Send message to other clients, too (requires proper localization, however) , AnswerClients [sendChan $ fromJust newMaster] ["CHAT", nickServer, loc "You're the new room master!"] ] processAction $ ModifyRoom (\r -> r{masterID = newMasterId , name = newRoomName , isRestrictedJoins = False , isRestrictedTeams = False , isRegisteredOnly = isSpecial r} ) newRoom' <- io $ room'sM rnc id ri chans <- liftM (map sendChan) $! sameProtoClientsS proto processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo proto (maybeNick newMaster) newRoom')processAction (AddRoom roomName roomPassword) = do Just clId <- gets clientIndex rnc <- gets roomsClients proto <- client's clientProto n <- client's nick let rm = newRoom{ masterID = Just clId, name = roomName, password = roomPassword, roomProto = proto } rId <- io $ addRoom rnc rm processAction $ MoveToRoom rId chans <- liftM (map sendChan) $! sameProtoClientsS proto mapM_ processAction [ AnswerClients chans ("ROOM" : "ADD" : roomInfo proto n rm{playersIn = 1}) ]processAction RemoveRoom = do Just clId <- gets clientIndex rnc <- gets roomsClients ri <- io $ clientRoomM rnc clId roomName <- io $ room'sM rnc name ri others <- othersChans proto <- client's clientProto chans <- liftM (map sendChan) $! sameProtoClientsS proto mapM_ processAction [ AnswerClients chans ["ROOM", "DEL", roomName], AnswerClients others ["ROOMABANDONED", roomName] ] io $ removeRoom rnc riprocessAction SendUpdateOnThisRoom = do Just clId <- gets clientIndex proto <- client's clientProto rnc <- gets roomsClients ri <- io $ clientRoomM rnc clId rm <- io $ room'sM rnc id ri masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm) chans <- liftM (map sendChan) $! sameProtoClientsS proto processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo proto (maybeNick masterCl) rm)processAction UnreadyRoomClients = do ri <- clientRoomA roomPlayers <- roomClientsS ri pr <- client's clientProto mapM_ processAction [ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr . map nick . filter (not . isMaster) $ roomPlayers , ModifyRoomClients (\cl -> cl{isReady = isMaster cl, isJoinedMidGame = False}) , ModifyRoom (\r -> r{readyPlayers = 1}) ] where notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicksprocessAction FinishGame = do rnc <- gets roomsClients ri <- clientRoomA thisRoomChans <- liftM (map sendChan) $ roomClientsS ri joinedMidGame <- liftM (filter isJoinedMidGame) $ roomClientsS ri answerRemovedTeams <- io $ room'sM rnc (\r -> let gi = fromJust $ gameInfo r in concatMap (\c -> (answerFullConfigParams c (mapParams r) (params r)) ++ (map (\t -> AnswerClients [sendChan c] ["REMOVE_TEAM", t]) $ leftTeams gi) ) joinedMidGame ) ri rteams <- io $ room'sM rnc (L.nub . rejoinedTeams . fromJust . gameInfo) ri mapM_ (processAction . RemoveTeam) rteams mapM_ processAction $ ( SaveReplay : ModifyRoom (\r -> r{ gameInfo = Nothing, readyPlayers = 0 } ) : SendUpdateOnThisRoom : AnswerClients thisRoomChans ["ROUND_FINISHED"] : answerRemovedTeams ) ++ [UnreadyRoomClients]processAction (SendTeamRemovalMessage teamName) = do chans <- othersChans mapM_ processAction [ AnswerClients chans ["EM", rmTeamMsg], ModifyRoom (\r -> r{ gameInfo = liftM (\g -> g{ teamsInGameNumber = teamsInGameNumber g - 1 , lastFilteredTimedMsg = Nothing , roundMsgs = (if isJust $ lastFilteredTimedMsg g then ((:) rmTeamMsg . (:) (fromJust $ lastFilteredTimedMsg g)) else ((:) rmTeamMsg)) $ roundMsgs g }) $ gameInfo r }) ] rnc <- gets roomsClients ri <- clientRoomA gi <- io $ room'sM rnc gameInfo ri when (0 == teamsInGameNumber (fromJust gi)) $ processAction FinishGame where rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamNameprocessAction (RemoveTeam teamName) = do (Just ci) <- gets clientIndex rnc <- gets roomsClients ri <- clientRoomA inGame <- io $ do r <- room'sM rnc (isJust . gameInfo) ri c <- client'sM rnc isInGame ci return $ r && c chans <- othersChans mapM_ processAction $ ModifyRoom (\r -> r{ teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r , gameInfo = liftM (\g -> g{leftTeams = teamName : leftTeams g}) $ gameInfo r }) : SendUpdateOnThisRoom : AnswerClients chans ["REMOVE_TEAM", teamName] : [SendTeamRemovalMessage teamName | inGame]processAction RemoveClientTeams = do (Just ci) <- gets clientIndex rnc <- gets roomsClients n <- client's nick removeTeamActions <- io $ do rId <- clientRoomM rnc ci roomTeams <- room'sM rnc teams rId return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == n) $ roomTeams mapM_ processAction removeTeamActionsprocessAction SetRandomSeed = do ri <- clientRoomA thisRoomChans <- liftM (map sendChan) $ roomClientsS ri seed <- liftM showB $ io $ (randomRIO (0, 10^9) :: IO Int) mapM_ processAction [ ModifyRoom (\r -> r{mapParams = Map.insert "SEED" seed $ mapParams r}) , AnswerClients thisRoomChans ["CFG", "SEED", seed] ]processAction CheckRegistered = do (Just ci) <- gets clientIndex n <- client's nick h <- client's host p <- client's clientProto checker <- client's isChecker uid <- client's clUID -- allow multiple checker logins haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS if (not checker) && haveSameNick then if p < 38 then processAction $ ByeClient $ loc "Nickname is already in use" else mapM_ processAction [NoticeMessage NickAlreadyInUse, ModifyClient $ \c -> c{nick = B.empty}] else do db <- gets (dbQueries . serverInfo) io $ writeChan db $ CheckAccount ci (hashUnique uid) n h return ()processAction ClearAccountsCache = do dbq <- gets (dbQueries . serverInfo) io $ writeChan dbq ClearCache return ()processAction (ProcessAccountInfo info) = do si <- gets serverInfo case info of HasAccount passwd isAdmin isContr -> do b <- isBanned c <- client's isChecker when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin isContr Guest | isRegisteredUsersOnly si -> do processAction $ ByeClient $ loc "This server only allows registered users to join." | otherwise -> do b <- isBanned c <- client's isChecker when (not b) $ if c then checkerLogin "" False False else processAction JoinLobby Admin -> mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] ReplayName fn -> processAction $ ShowReplay fn where isBanned = do processAction $ CheckBanned False liftM B.null $ client's nick checkerLogin _ False _ = processAction $ ByeClient $ loc "No checker rights" checkerLogin p True _ = do wp <- client's webPassword chan <- client's sendChan mapM_ processAction $ if wp == p then [ModifyClient $ \c -> c{logonPassed = True} , AnswerClients [chan] ["LOGONPASSED"] ] else [ByeClient $ loc "Authentication failed"] playerLogin p a contr = do cl <- client's id mapM_ processAction [ AnswerClients [sendChan cl] $ ("ASKPASSWORD") : if clientProto cl < 48 then [] else [serverSalt cl] , ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr}) ]processAction JoinLobby = do chan <- client's sendChan rnc <- gets roomsClients clientNick <- client's nick clProto <- client's clientProto isAuthenticated <- client's isRegistered isAdmin <- client's isAdministrator isContr <- client's isContributor loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients let authenticatedNicks = L.map nick . L.filter isRegistered $ loggedInClients let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients let contrNicks = L.map nick . L.filter isContributor $ loggedInClients inRoomNicks <- io $ allClientsM rnc >>= filterM (liftM ((/=) lobbyId) . clientRoomM rnc) >>= mapM (client'sM rnc nick) let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin], ["c" | isContr]] roomsInfoList <- io $ do rooms <- roomsM rnc mapM (\r -> (mapM (client'sM rnc id) $ masterID r) >>= \cn -> return $ roomInfo clProto (maybeNick cn) r) $ filter (\r -> (roomProto r == clProto)) rooms mapM_ processAction . concat $ [ [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]] , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] , [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks] , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks] , [AnswerClients [chan] ("CLIENT_FLAGS" : "+c" : contrNicks) | not $ null contrNicks] , [AnswerClients [chan] ("CLIENT_FLAGS" : "+i" : inRoomNicks) | not $ null inRoomNicks] , [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS", B.concat["+" , clFlags], clientNick] | not $ B.null clFlags] , [ModifyClient (\cl -> cl{logonPassed = True, isVisible = True})] , [SendServerMessage] , [AnswerClients [chan] ("ROOMS" : concat roomsInfoList)] ]processAction (KickClient kickId) = do modify (\s -> s{clientIndex = Just kickId}) clHost <- client's host currentTime <- io getCurrentTime mapM_ processAction [ AddIP2Bans clHost (loc "60 seconds cooldown after kick") (addUTCTime 60 currentTime) , ModifyClient (\c -> c{isKickedFromServer = True}) , ByeClient $ loc "Kicked" ]processAction (BanClient seconds reason banId) = do modify (\s -> s{clientIndex = Just banId}) clHost <- client's host currentTime <- io getCurrentTime let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"] mapM_ processAction [ AddIP2Bans clHost msg (addUTCTime seconds currentTime) , KickClient banId ]processAction (BanIP ip seconds reason) = do currentTime <- io getCurrentTime let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"] processAction $ AddIP2Bans ip msg (addUTCTime seconds currentTime)processAction (BanNick n seconds reason) = do currentTime <- io getCurrentTime let msg = if seconds > 60 * 60 * 24 * 365 then B.concat ["Permanent ban (", reason, ")"] else B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"] processAction $ AddNick2Bans n msg (addUTCTime seconds currentTime)processAction BanList = do time <- io $ getCurrentTime ch <- client's sendChan b <- gets (B.intercalate "\n" . concatMap (ban2Str time) . bans . serverInfo) processAction $ AnswerClients [ch] ["BANLIST", b] where ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time] ban2Str time (BanByNick b r t) = ["N", b, r, B.pack . show $ t `diffUTCTime` time]processAction (Unban entry) = do processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s}) where f (BanByIP bip _ _) = bip == entry f (BanByNick bn _ _) = bn == entryprocessAction (KickRoomClient kickId) = do modify (\s -> s{clientIndex = Just kickId}) ch <- client's sendChan mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]processAction (AddClient cl) = do rnc <- gets roomsClients si <- gets serverInfo newClId <- io $ do ci <- addClient rnc cl _ <- Exception.mask (\x -> forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci x) infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl)) return ci modify (\s -> s{clientIndex = Just newClId}) jm <- gets joinsMonitor pass <- io $ joinsSentry jm (host cl) (connectTime cl) if pass then mapM_ processAction [ CheckBanned True , AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server https://www.hedgewars.org/", serverVersion] ] else processAction $ ByeClient $ loc "Reconnected too fast"processAction (AddNick2Bans n reason expiring) = do processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})processAction (AddIP2Bans ip reason expiring) = do (Just ci) <- gets clientIndex rc <- gets removedClients when (not $ ci `Set.member` rc) $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})processAction (CheckBanned byIP) = do clTime <- client's connectTime clNick <- client's nick clHost <- client's host si <- gets serverInfo let (validBans, expiredBans) = L.partition (checkNotExpired clTime) $ bans si let ban = L.find (checkBan byIP clHost clNick) $ validBans mapM_ processAction $ [ModifyServerInfo (\s -> s{bans = validBans}) | not $ null expiredBans] ++ [ByeClient (getBanReason $ fromJust ban) | isJust ban] where checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0 checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0 checkBan True ip _ (BanByIP bip _ _) = isMatch bip ip checkBan False _ n (BanByNick bn _ _) = isMatch bn n checkBan _ _ _ _ = False isMatch :: B.ByteString -> B.ByteString -> Bool isMatch rexp src = (==) (Just True) $ mrexp rexp >>= flip matchM src mrexp :: B.ByteString -> Maybe TDFAB.Regex mrexp = makeRegexOptsM TDFA.defaultCompOpt{TDFA.caseSensitive = False} TDFA.defaultExecOpt getBanReason (BanByIP _ msg _) = msg getBanReason (BanByNick _ msg _) = msgprocessAction PingAll = do rnc <- gets roomsClients io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) cis <- io $ allClientsM rnc chans <- io $ mapM (client'sM rnc sendChan) cis io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis processAction $ AnswerClients chans ["PING"] where kickTimeouted rnc ci = do pq <- io $ client'sM rnc pingsQueue ci when (pq > 0) $ do withStateT (\as -> as{clientIndex = Just ci}) $ processAction (ByeClient $ loc "Ping timeout")-- when (pq > 1) $-- processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient hereprocessAction StatsAction = do si <- gets serverInfo when (not $ shutdownPending si) $ do rnc <- gets roomsClients (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) where st irnc = (length $ allRooms irnc, length $ allClients irnc)processAction RestartServer = do sp <- gets (shutdownPending . serverInfo) when (not sp) $ do sock <- gets (fromJust . serverSocket . serverInfo) args <- gets (runArgs . serverInfo) io $ do noticeM "Core" "Closing listening socket" sClose sock noticeM "Core" "Spawning new server" _ <- createProcess (proc "./hedgewars-server" args) return () processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})processAction Stats = do cls <- allClientsS rms <- allRoomsS let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls let roomsMap = Map.fromListWith (+) . map (\c -> (roomProto c, 1 :: Int)) . filter ((/=) 0 . roomProto) $ rms let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"]) . concatMap (\p -> [ "<tr><td>", protoNumber2ver p , "</td><td>", showB $ Map.findWithDefault 0 p clientsMap , "</td><td>", showB $ Map.findWithDefault 0 p roomsMap , "</td></tr>"]) . Set.toList $ keys processAction $ Warning versionsStatsprocessAction (Random chans items) = do let i = if null items then [loc "heads", loc "tails"] else items n <- io $ randomRIO (0, length i - 1) processAction $ AnswerClients chans ["CHAT", if null items then nickRandomCoin else nickRandomCustom, i !! n]processAction (LoadGhost location) = do ri <- clientRoomA rnc <- gets roomsClients thisRoomChans <- liftM (map sendChan) $ roomClientsS ri#if defined(OFFICIAL_SERVER) rm <- io $ room'sM rnc id ri points <- io $ loadFile (B.unpack $ "ghosts/" `B.append` sanitizeName location) when (roomProto rm > 51) $ do processAction $ ModifyRoom $ \r -> r{params = Map.insert "DRAWNMAP" [prependGhostPoints (toP points) $ head $ (params r) Map.! "DRAWNMAP"] (params r)}#endif cl <- client's id rm <- io $ room'sM rnc id ri mapM_ processAction $ map (replaceChans thisRoomChans) $ answerFullConfigParams cl (mapParams rm) (params rm) where loadFile :: String -> IO [Int] loadFile fileName = E.handle (\(e :: SomeException) -> return []) $ do points <- liftM read $ readFile fileName return (points `deepseq` points) replaceChans chans (AnswerClients _ msg) = AnswerClients chans msg replaceChans _ a = a toP [] = [] toP (p1:p2:ps) = (fromIntegral p1, fromIntegral p2) : toP ps{- let a = map (replaceChans chans) $ answerFullConfigParams cl mp p-}#if defined(OFFICIAL_SERVER)processAction SaveReplay = do ri <- clientRoomA rnc <- gets roomsClients readyCheckersIds <- io $ do r <- room'sM rnc id ri saveReplay r allci <- allClientsM rnc filterM (client'sM rnc isReadyChecker) allci when (not $ null readyCheckersIds) $ do oldci <- gets clientIndex withStateT (\s -> s{clientIndex = Just $ head readyCheckersIds}) $ processAction CheckRecord modify (\s -> s{clientIndex = oldci}) where isReadyChecker cl = isChecker cl && isReady clprocessAction CheckRecord = do p <- client's clientProto c <- client's sendChan ri <- clientRoomA rnc <- gets roomsClients blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS (cinfo, l) <- io $ loadReplay (fromIntegral p) blackList when (isJust cinfo) $ mapM_ processAction [ AnswerClients [c] ("REPLAY" : l) , ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False} ]processAction (CheckFailed msg) = do Just (CheckInfo fileName _ _) <- client's checkInfo io $ moveFailedRecord fileNameprocessAction (CheckSuccess info) = do Just (CheckInfo fileName teams gameDetails) <- client's checkInfo p <- client's clientProto si <- gets serverInfo when (isJust gameDetails) $ io $ writeChan (dbQueries si) $ StoreAchievements p (B.pack fileName) (map toPair teams) (fromJust gameDetails) info io $ moveCheckedRecord fileName where toPair t = (teamname t, teamowner t)processAction (QueryReplay rname) = do (Just ci) <- gets clientIndex si <- gets serverInfo uid <- client's clUID io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) rname#elseprocessAction SaveReplay = return ()processAction CheckRecord = return ()processAction (CheckFailed _) = return ()processAction (CheckSuccess _) = return ()processAction (QueryReplay _) = processAction $ Warning $ loc "This server does not support replays!"#endifprocessAction (ShowReplay rname) = do c <- client's sendChan cl <- client's id let fileName = B.concat ["checked/", if B.isPrefixOf "replays/" rname then B.drop 8 rname else rname] cInfo <- liftIO $ E.handle (\(e :: SomeException) -> warningM "REPLAYS" (B.unpack $ B.concat ["Problems reading ", fileName, ": ", B.pack $ show e]) >> return Nothing) $ do (t, p1, p2, msgs) <- liftM read $ readFile (B.unpack fileName) return $ Just (t, Map.fromList p1, Map.fromList p2, reverse msgs) let (teams', params1, params2, roundMsgs') = fromJust cInfo when (isJust cInfo) $ do mapM_ processAction $ concat [ [AnswerClients [c] ["JOINED", nick cl]] , answerFullConfigParams cl params1 params2 , answerAllTeams cl teams' , [AnswerClients [c] ["RUN_GAME"]] , [AnswerClients [c] $ "EM" : roundMsgs'] , [AnswerClients [c] ["KICKED"]] ]processAction (SaveRoom rname) = do rnc <- gets roomsClients ri <- clientRoomA rm <- io $ room'sM rnc id ri liftIO $ YAML.encodeFile (B.unpack rname) (greeting rm, roomSaves rm)processAction (LoadRoom rname) = do Right (g, rs) <- io $ YAML.decodeFileEither (B.unpack rname) processAction $ ModifyRoom $ \r -> r{greeting = g, roomSaves = rs}processAction Cleanup = do jm <- gets joinsMonitor io $ do t <- getCurrentTime cleanup jm tprocessAction (RegisterEvent e) = do actions <- registerEvent e mapM_ processAction actionsprocessAction (ReactCmd cmd) = do (Just ci) <- gets clientIndex rnc <- gets roomsClients actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) forM_ (actions `deepseq` actions) processActionprocessAction CheckVotes = checkVotes >>= mapM_ processAction