diff -r 31570b766315 -r ed5a6478e710 gameServer/Actions.hs --- a/gameServer/Actions.hs Tue Nov 10 18:16:35 2015 +0100 +++ b/gameServer/Actions.hs Tue Nov 10 20:43:13 2015 +0100 @@ -1,3 +1,21 @@ +{- + * Hedgewars, a free turn based strategy game + * Copyright (c) 2004-2015 Andrey Korotaev + * + * 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 where @@ -33,10 +51,9 @@ import Consts import ConfigFile import EngineInteraction - - -type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] - +import FloodDetection +import HWProtoCore +import Votes othersChans :: StateT ServerState IO [ClientChan] othersChans = do @@ -180,6 +197,7 @@ mapM_ processAction [ AnswerClients chans ["JOINED", clNick] , AnswerClients allClientsChans ["CLIENT_FLAGS", "+i", clNick] + , RegisterEvent RoomJoin ] @@ -221,7 +239,10 @@ ri <- clientRoomA rnc <- gets roomsClients specialRoom <- io $ room'sM rnc isSpecial ri - newMasterId <- liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc 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 @@ -327,14 +348,17 @@ 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 -> + 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) + (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 @@ -357,8 +381,9 @@ ModifyRoom (\r -> r{ gameInfo = liftM (\g -> g{ teamsInGameNumber = teamsInGameNumber g - 1 - , roundMsgs = (if isJust $ lastFilteredTimedMsg g then (:) (fromJust $ lastFilteredTimedMsg g) else id) - $ rmTeamMsg : roundMsgs g + , lastFilteredTimedMsg = Nothing + , roundMsgs = (if isJust $ lastFilteredTimedMsg g then ((:) rmTeamMsg . (:) (fromJust $ lastFilteredTimedMsg g)) else ((:) rmTeamMsg)) + $ roundMsgs g }) $ gameInfo r }) ] @@ -394,15 +419,25 @@ 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 -> teamownerId t == ci) $ roomTeams + return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == n) $ roomTeams mapM_ processAction removeTeamActions +processAction 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 @@ -454,12 +489,18 @@ checkerLogin _ False _ = processAction $ ByeClient $ loc "No checker rights" checkerLogin p True _ = do wp <- client's webPassword - processAction $ - if wp == p then ModifyClient $ \c -> c{logonPassed = True} else ByeClient $ loc "Authentication failed" + 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 - chan <- client's sendChan + cl <- client's id mapM_ processAction [ - AnswerClients [chan] ["ASKPASSWORD"] + AnswerClients [sendChan cl] $ ("ASKPASSWORD") : if clientProto cl < 48 then [] else [serverSalt cl] , ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr}) ] @@ -524,7 +565,7 @@ processAction (BanNick n seconds reason) = do currentTime <- io getCurrentTime - let msg = + let msg = if seconds > 60 * 60 * 24 * 365 then B.concat ["Permanent ban (", reason, ")"] else @@ -562,20 +603,25 @@ si <- gets serverInfo newClId <- io $ do ci <- addClient rnc cl - _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci) + _ <- 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}) - mapM_ processAction - [ - AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion] - , CheckBanned True - , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl) - ] + + jm <- gets joinsMonitor + pass <- io $ joinsSentry jm (host cl) (connectTime cl) + if pass then + mapM_ processAction + [ + CheckBanned True + , AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://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}) @@ -592,11 +638,11 @@ clNick <- client's nick clHost <- client's host si <- gets serverInfo - let validBans = filter (checkNotExpired clTime) $ bans si + 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}) - : [ByeClient (getBanReason $ fromJust ban) | isJust ban] + [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 @@ -698,12 +744,8 @@ blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS - readyCheckersIds <- io $ do - allci <- allClientsM rnc - filterM (client'sM rnc (isJust . checkInfo)) allci - (cinfo, l) <- io $ loadReplay (fromIntegral p) blackList - when (not . null $ l) $ + when (isJust cinfo) $ mapM_ processAction [ AnswerClients [c] ("REPLAY" : l) , ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False} @@ -711,14 +753,16 @@ processAction (CheckFailed msg) = do - Just (CheckInfo fileName _) <- client's checkInfo + Just (CheckInfo fileName _ _) <- client's checkInfo io $ moveFailedRecord fileName processAction (CheckSuccess info) = do - Just (CheckInfo fileName teams) <- client's checkInfo + Just (CheckInfo fileName teams gameDetails) <- client's checkInfo + p <- client's clientProto si <- gets serverInfo - io $ writeChan (dbQueries si) $ StoreAchievements (B.pack fileName) (map toPair teams) info + 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) @@ -759,3 +803,35 @@ , [AnswerClients [c] $ "EM" : roundMsgs'] , [AnswerClients [c] ["KICKED"]] ] + +processAction (SaveRoom rname) = do + rnc <- gets roomsClients + ri <- clientRoomA + rm <- io $ room'sM rnc id ri + liftIO $ writeFile (B.unpack rname) $ show (greeting rm, roomSaves rm) + +processAction (LoadRoom rname) = do + (g, rs) <- liftIO $ liftM read $ readFile (B.unpack rname) + processAction $ ModifyRoom $ \r -> r{greeting = g, roomSaves = rs} + +processAction Cleanup = do + jm <- gets joinsMonitor + + io $ do + t <- getCurrentTime + cleanup jm t + + +processAction (RegisterEvent e) = do + actions <- registerEvent e + mapM_ processAction actions + + +processAction (ReactCmd cmd) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) + forM_ (actions `deepseq` actions) processAction + +processAction CheckVotes = + checkVotes >>= mapM_ processAction \ No newline at end of file