# HG changeset patch # User nemo # Date 1303917105 14400 # Node ID bf7bba60ed93a07dcc9cb8c55c87eabcfe2a4606 # Parent 0b71d382b73b63b146285f5947a57639a93329cd update iphone too diff -r 0b71d382b73b -r bf7bba60ed93 gameServer/Actions.hs --- a/gameServer/Actions.hs Wed Apr 27 11:05:56 2011 -0400 +++ b/gameServer/Actions.hs Wed Apr 27 11:11:45 2011 -0400 @@ -1,481 +1,481 @@ -{-# LANGUAGE OverloadedStrings #-} -module Actions where - -import Control.Concurrent -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import qualified Data.List as L -import qualified Control.Exception as Exception -import System.Log.Logger -import Control.Monad -import Data.Time -import Data.Maybe -import Control.Monad.Reader -import Control.Monad.State.Strict -import qualified Data.ByteString.Char8 as B -import Control.DeepSeq -import Data.Unique -import Control.Arrow -import Control.Exception -import OfficialServer.GameReplayStore ------------------------------ -import CoreTypes -import Utils -import ClientIO -import ServerState -import Consts -import ConfigFile - -data Action = - AnswerClients ![ClientChan] ![B.ByteString] - | SendServerMessage - | SendServerVars - | MoveToRoom RoomIndex - | MoveToLobby B.ByteString - | RemoveTeam B.ByteString - | RemoveRoom - | UnreadyRoomClients - | JoinLobby - | ProtocolError B.ByteString - | Warning B.ByteString - | NoticeMessage Notice - | ByeClient B.ByteString - | KickClient ClientIndex - | KickRoomClient ClientIndex - | BanClient NominalDiffTime B.ByteString ClientIndex - | ChangeMaster - | RemoveClientTeams ClientIndex - | ModifyClient (ClientInfo -> ClientInfo) - | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) - | ModifyRoom (RoomInfo -> RoomInfo) - | ModifyServerInfo (ServerInfo -> ServerInfo) - | AddRoom B.ByteString B.ByteString - | CheckRegistered - | ClearAccountsCache - | ProcessAccountInfo AccountInfo - | AddClient ClientInfo - | DeleteClient ClientIndex - | PingAll - | StatsAction - | RestartServer Bool - | AddNick2Bans B.ByteString B.ByteString UTCTime - | AddIP2Bans B.ByteString B.ByteString UTCTime - | CheckBanned - | SaveReplay - - -type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] - -instance NFData Action where - rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` () - rnf a = a `seq` () - -instance NFData B.ByteString -instance NFData (Chan a) - - -othersChans :: StateT ServerState IO [ClientChan] -othersChans = do - cl <- client's id - ri <- clientRoomA - liftM (map sendChan . filter (/= cl)) $ roomClientsS ri - -processAction :: 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 logonPassed - - when (ri /= lobbyId) $ do - processAction $ MoveToLobby ("quit: " `B.append` msg) - return () - - clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS - io $ - infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg) - - processAction $ AnswerClients [chan] ["BYE", msg] - when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] - - 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} - -processAction (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 (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 si - - -processAction (MoveToRoom ri) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - - io $ do - modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci - modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri - moveClientToRoom rnc ri ci - - chans <- liftM (map sendChan) $ roomClientsS ri - clNick <- client's nick - - processAction $ AnswerClients chans ["JOINED", clNick] - - -processAction (MoveToLobby msg) = do - (Just ci) <- gets clientIndex - ri <- clientRoomA - rnc <- gets roomsClients - (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri - ready <- client's isReady - master <- client's isMaster --- client <- client's id - clNick <- client's nick - chans <- othersChans - - if master then - if gameProgress && playersNum > 1 then - mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci] - else - processAction RemoveRoom - else - mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci] - - -- when not removing room - when (not master || (gameProgress && playersNum > 1)) . io $ do - modifyRoom rnc (\r -> r{ - playersIn = playersIn r - 1, - readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r - }) ri - moveClientToLobby rnc ci - -processAction ChangeMaster = do - (Just ci) <- gets clientIndex - ri <- clientRoomA - rnc <- gets roomsClients - newMasterId <- liftM (head . filter (/= ci)) . io $ roomClientsIndicesM rnc ri - newMaster <- io $ client'sM rnc id newMasterId - let newRoomName = nick newMaster - mapM_ processAction [ - ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}), - ModifyClient2 newMasterId (\c -> c{isMaster = True}), - AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"] - ] - -processAction (AddRoom roomName roomPassword) = do - Just clId <- gets clientIndex - rnc <- gets roomsClients - proto <- io $ client'sM rnc clientProto clId - - let rm = newRoom{ - masterID = clId, - name = roomName, - password = roomPassword, - roomProto = proto - } - - rId <- io $ addRoom rnc rm - - processAction $ MoveToRoom rId - - chans <- liftM (map sendChan) $! roomClientsS lobbyId - - mapM_ processAction [ - AnswerClients chans ["ROOM", "ADD", roomName] - , ModifyClient (\cl -> cl{isMaster = True}) - ] - - -processAction RemoveRoom = do - Just clId <- gets clientIndex - rnc <- gets roomsClients - ri <- io $ clientRoomM rnc clId - roomName <- io $ room'sM rnc name ri - others <- othersChans - lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId - - mapM_ processAction [ - AnswerClients lobbyChans ["ROOM", "DEL", roomName], - AnswerClients others ["ROOMABANDONED", roomName] - ] - - io $ removeRoom rnc ri - - -processAction (UnreadyRoomClients) = do - rnc <- gets roomsClients - ri <- clientRoomA - roomPlayers <- roomClientsS ri - roomClIDs <- io $ roomClientsIndicesM rnc ri - pr <- client's clientProto - processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers) - io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs - processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) - where - notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks - - -processAction (RemoveTeam teamName) = do - rnc <- gets roomsClients - ri <- clientRoomA - inGame <- io $ room'sM rnc gameinprogress ri - chans <- othersChans - if not $ inGame then - mapM_ processAction [ - AnswerClients chans ["REMOVE_TEAM", teamName], - ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) - ] - else - mapM_ processAction [ - AnswerClients chans ["EM", rmTeamMsg], - ModifyRoom (\r -> r{ - teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, - leftTeams = teamName : leftTeams r, - roundMsgs = roundMsgs r Seq.|> rmTeamMsg - }) - ] - where - rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName - - -processAction (RemoveClientTeams clId) = do - rnc <- gets roomsClients - - removeTeamActions <- io $ do - clNick <- client'sM rnc nick clId - rId <- clientRoomM rnc clId - roomTeams <- room'sM rnc teams rId - return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams - - mapM_ processAction removeTeamActions - - - -processAction CheckRegistered = do - (Just ci) <- gets clientIndex - n <- client's nick - h <- client's host - p <- client's clientProto - uid <- client's clUID - haveSameNick <- liftM (not . null . tail . filter (\c -> nick c == n)) allClientsS - if haveSameNick then - if p < 38 then - mapM_ processAction [ByeClient "Nickname is already in use", removeNick] - else - mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick] - else - do - db <- gets (dbQueries . serverInfo) - io $ writeChan db $ CheckAccount ci (hashUnique uid) n h - return () - where - removeNick = ModifyClient (\c -> c{nick = ""}) - - -processAction ClearAccountsCache = do - dbq <- gets (dbQueries . serverInfo) - io $ writeChan dbq ClearCache - return () - - -processAction (ProcessAccountInfo info) = - case info of - HasAccount passwd isAdmin -> do - chan <- client's sendChan - mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})] - Guest -> - processAction JoinLobby - Admin -> do - mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] - - -processAction JoinLobby = do - chan <- client's sendChan - clientNick <- client's nick - (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS - mapM_ processAction $ - AnswerClients clientsChans ["LOBBY:JOINED", clientNick] - : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks) - : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] - - -processAction (KickClient kickId) = do - modify (\s -> s{clientIndex = Just kickId}) - processAction $ ByeClient "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, "seconds (", reason, ")"] - mapM_ processAction [ - AddIP2Bans clHost msg (addUTCTime seconds currentTime) - , KickClient banId - ] - - -processAction (KickRoomClient kickId) = do - modify (\s -> s{clientIndex = Just kickId}) - ch <- client's sendChan - mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"] - - -processAction (AddClient cl) = do - rnc <- gets roomsClients - si <- gets serverInfo - newClId <- io $ do - ci <- addClient rnc cl - _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci) - - 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 - , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl) - ] - - -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 = do - clTime <- client's connectTime - clNick <- client's nick - clHost <- client's host - si <- gets serverInfo - let validBans = filter (checkNotExpired clTime) $ bans si - let ban = L.find (checkBan clHost clNick) $ validBans - when (isJust ban) $ - mapM_ processAction [ - ModifyServerInfo (\s -> s{bans = validBans}) - , ByeClient (getBanReason $ fromJust ban) - ] - where - checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0 - checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0 - checkBan ip _ (BanByIP bip _ _) = bip == ip - checkBan _ n (BanByNick bn _ _) = bn == n - getBanReason (BanByIP _ msg _) = msg - getBanReason (BanByNick _ msg _) = msg - -processAction 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) $ - withStateT (\as -> as{clientIndex = Just ci}) $ - processAction (ByeClient "Ping timeout") - - -processAction StatsAction = do - rnc <- gets roomsClients - si <- gets serverInfo - (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 force) = do - if force then do - throw RestartException - else - processAction $ ModifyServerInfo (\s -> s{restartPending=True}) - -processAction SaveReplay = do - ri <- clientRoomA - rnc <- gets roomsClients - io $ do - r <- room'sM rnc id ri - saveReplay r +{-# LANGUAGE OverloadedStrings #-} +module Actions where + +import Control.Concurrent +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import qualified Data.List as L +import qualified Control.Exception as Exception +import System.Log.Logger +import Control.Monad +import Data.Time +import Data.Maybe +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.ByteString.Char8 as B +import Control.DeepSeq +import Data.Unique +import Control.Arrow +import Control.Exception +import OfficialServer.GameReplayStore +----------------------------- +import CoreTypes +import Utils +import ClientIO +import ServerState +import Consts +import ConfigFile + +data Action = + AnswerClients ![ClientChan] ![B.ByteString] + | SendServerMessage + | SendServerVars + | MoveToRoom RoomIndex + | MoveToLobby B.ByteString + | RemoveTeam B.ByteString + | RemoveRoom + | UnreadyRoomClients + | JoinLobby + | ProtocolError B.ByteString + | Warning B.ByteString + | NoticeMessage Notice + | ByeClient B.ByteString + | KickClient ClientIndex + | KickRoomClient ClientIndex + | BanClient NominalDiffTime B.ByteString ClientIndex + | ChangeMaster + | RemoveClientTeams ClientIndex + | ModifyClient (ClientInfo -> ClientInfo) + | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) + | ModifyRoom (RoomInfo -> RoomInfo) + | ModifyServerInfo (ServerInfo -> ServerInfo) + | AddRoom B.ByteString B.ByteString + | CheckRegistered + | ClearAccountsCache + | ProcessAccountInfo AccountInfo + | AddClient ClientInfo + | DeleteClient ClientIndex + | PingAll + | StatsAction + | RestartServer Bool + | AddNick2Bans B.ByteString B.ByteString UTCTime + | AddIP2Bans B.ByteString B.ByteString UTCTime + | CheckBanned + | SaveReplay + + +type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] + +instance NFData Action where + rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` () + rnf a = a `seq` () + +instance NFData B.ByteString +instance NFData (Chan a) + + +othersChans :: StateT ServerState IO [ClientChan] +othersChans = do + cl <- client's id + ri <- clientRoomA + liftM (map sendChan . filter (/= cl)) $ roomClientsS ri + +processAction :: 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 logonPassed + + when (ri /= lobbyId) $ do + processAction $ MoveToLobby ("quit: " `B.append` msg) + return () + + clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS + io $ + infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg) + + processAction $ AnswerClients [chan] ["BYE", msg] + when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] + + 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} + +processAction (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 (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 si + + +processAction (MoveToRoom ri) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + + io $ do + modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci + modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri + moveClientToRoom rnc ri ci + + chans <- liftM (map sendChan) $ roomClientsS ri + clNick <- client's nick + + processAction $ AnswerClients chans ["JOINED", clNick] + + +processAction (MoveToLobby msg) = do + (Just ci) <- gets clientIndex + ri <- clientRoomA + rnc <- gets roomsClients + (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri + ready <- client's isReady + master <- client's isMaster +-- client <- client's id + clNick <- client's nick + chans <- othersChans + + if master then + if gameProgress && playersNum > 1 then + mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci] + else + processAction RemoveRoom + else + mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci] + + -- when not removing room + when (not master || (gameProgress && playersNum > 1)) . io $ do + modifyRoom rnc (\r -> r{ + playersIn = playersIn r - 1, + readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r + }) ri + moveClientToLobby rnc ci + +processAction ChangeMaster = do + (Just ci) <- gets clientIndex + ri <- clientRoomA + rnc <- gets roomsClients + newMasterId <- liftM (head . filter (/= ci)) . io $ roomClientsIndicesM rnc ri + newMaster <- io $ client'sM rnc id newMasterId + let newRoomName = nick newMaster + mapM_ processAction [ + ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}), + ModifyClient2 newMasterId (\c -> c{isMaster = True}), + AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"] + ] + +processAction (AddRoom roomName roomPassword) = do + Just clId <- gets clientIndex + rnc <- gets roomsClients + proto <- io $ client'sM rnc clientProto clId + + let rm = newRoom{ + masterID = clId, + name = roomName, + password = roomPassword, + roomProto = proto + } + + rId <- io $ addRoom rnc rm + + processAction $ MoveToRoom rId + + chans <- liftM (map sendChan) $! roomClientsS lobbyId + + mapM_ processAction [ + AnswerClients chans ["ROOM", "ADD", roomName] + , ModifyClient (\cl -> cl{isMaster = True}) + ] + + +processAction RemoveRoom = do + Just clId <- gets clientIndex + rnc <- gets roomsClients + ri <- io $ clientRoomM rnc clId + roomName <- io $ room'sM rnc name ri + others <- othersChans + lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId + + mapM_ processAction [ + AnswerClients lobbyChans ["ROOM", "DEL", roomName], + AnswerClients others ["ROOMABANDONED", roomName] + ] + + io $ removeRoom rnc ri + + +processAction (UnreadyRoomClients) = do + rnc <- gets roomsClients + ri <- clientRoomA + roomPlayers <- roomClientsS ri + roomClIDs <- io $ roomClientsIndicesM rnc ri + pr <- client's clientProto + processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers) + io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs + processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) + where + notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks + + +processAction (RemoveTeam teamName) = do + rnc <- gets roomsClients + ri <- clientRoomA + inGame <- io $ room'sM rnc gameinprogress ri + chans <- othersChans + if not $ inGame then + mapM_ processAction [ + AnswerClients chans ["REMOVE_TEAM", teamName], + ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) + ] + else + mapM_ processAction [ + AnswerClients chans ["EM", rmTeamMsg], + ModifyRoom (\r -> r{ + teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, + leftTeams = teamName : leftTeams r, + roundMsgs = roundMsgs r Seq.|> rmTeamMsg + }) + ] + where + rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName + + +processAction (RemoveClientTeams clId) = do + rnc <- gets roomsClients + + removeTeamActions <- io $ do + clNick <- client'sM rnc nick clId + rId <- clientRoomM rnc clId + roomTeams <- room'sM rnc teams rId + return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams + + mapM_ processAction removeTeamActions + + + +processAction CheckRegistered = do + (Just ci) <- gets clientIndex + n <- client's nick + h <- client's host + p <- client's clientProto + uid <- client's clUID + haveSameNick <- liftM (not . null . tail . filter (\c -> nick c == n)) allClientsS + if haveSameNick then + if p < 38 then + mapM_ processAction [ByeClient "Nickname is already in use", removeNick] + else + mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick] + else + do + db <- gets (dbQueries . serverInfo) + io $ writeChan db $ CheckAccount ci (hashUnique uid) n h + return () + where + removeNick = ModifyClient (\c -> c{nick = ""}) + + +processAction ClearAccountsCache = do + dbq <- gets (dbQueries . serverInfo) + io $ writeChan dbq ClearCache + return () + + +processAction (ProcessAccountInfo info) = + case info of + HasAccount passwd isAdmin -> do + chan <- client's sendChan + mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})] + Guest -> + processAction JoinLobby + Admin -> do + mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] + chan <- client's sendChan + processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] + + +processAction JoinLobby = do + chan <- client's sendChan + clientNick <- client's nick + (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS + mapM_ processAction $ + AnswerClients clientsChans ["LOBBY:JOINED", clientNick] + : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks) + : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] + + +processAction (KickClient kickId) = do + modify (\s -> s{clientIndex = Just kickId}) + processAction $ ByeClient "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, "seconds (", reason, ")"] + mapM_ processAction [ + AddIP2Bans clHost msg (addUTCTime seconds currentTime) + , KickClient banId + ] + + +processAction (KickRoomClient kickId) = do + modify (\s -> s{clientIndex = Just kickId}) + ch <- client's sendChan + mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"] + + +processAction (AddClient cl) = do + rnc <- gets roomsClients + si <- gets serverInfo + newClId <- io $ do + ci <- addClient rnc cl + _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci) + + 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 + , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl) + ] + + +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 = do + clTime <- client's connectTime + clNick <- client's nick + clHost <- client's host + si <- gets serverInfo + let validBans = filter (checkNotExpired clTime) $ bans si + let ban = L.find (checkBan clHost clNick) $ validBans + when (isJust ban) $ + mapM_ processAction [ + ModifyServerInfo (\s -> s{bans = validBans}) + , ByeClient (getBanReason $ fromJust ban) + ] + where + checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0 + checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0 + checkBan ip _ (BanByIP bip _ _) = bip == ip + checkBan _ n (BanByNick bn _ _) = bn == n + getBanReason (BanByIP _ msg _) = msg + getBanReason (BanByNick _ msg _) = msg + +processAction 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) $ + withStateT (\as -> as{clientIndex = Just ci}) $ + processAction (ByeClient "Ping timeout") + + +processAction StatsAction = do + rnc <- gets roomsClients + si <- gets serverInfo + (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 force) = do + if force then do + throw RestartException + else + processAction $ ModifyServerInfo (\s -> s{restartPending=True}) + +processAction SaveReplay = do + ri <- clientRoomA + rnc <- gets roomsClients + io $ do + r <- room'sM rnc id ri + saveReplay r diff -r 0b71d382b73b -r bf7bba60ed93 project_files/HedgewarsMobile/Hedgewars.xcodeproj/project.pbxproj --- a/project_files/HedgewarsMobile/Hedgewars.xcodeproj/project.pbxproj Wed Apr 27 11:05:56 2011 -0400 +++ b/project_files/HedgewarsMobile/Hedgewars.xcodeproj/project.pbxproj Wed Apr 27 11:11:45 2011 -0400 @@ -1336,7 +1336,7 @@ ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/sh; - shellScript = "#copy new stuff over old stuff\nrm -rf ${PROJECT_DIR}/Data\n\n#create config.inc\necho \"Updating config file...\"\nPROTO=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep HEDGEWARS_PROTO_VER | cut -d ' ' -f 3`\nMAJN=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep CPACK_PACKAGE_VERSION_MAJOR | xargs | cut -d ' ' -f 3`\nMINN=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep CPACK_PACKAGE_VERSION_MINOR | xargs | cut -d ' ' -f 3`\nPATN=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep CPACK_PACKAGE_VERSION_PATCH | xargs | cut -d ' ' -f 3 | cut -d '$' -f 1`\nREVN=-`/usr/local/bin/hg id -n ${PROJECT_DIR}/../../`\necho \"const cNetProtoVersion = $PROTO; const cVersionString = '${MAJN}.${MINN}.${PATN}${REVN}'; const cLuaLibrary = '';\" > ${PROJECT_DIR}/../../hedgewars/config.inc\n\necho \"Copying Data...\"\ncp -R ${PROJECT_DIR}/../../share/hedgewars/Data ${PROJECT_DIR}/Data\n\n#copy some files from QTfrontend/res\necho \"Fetching additional graphics from QTfrontend/res...\"\nmkdir ${PROJECT_DIR}/Data/Graphics/Btn\ncp ${PROJECT_DIR}/../../QTfrontend/res/btn*.png ${PROJECT_DIR}/Data/Graphics/Btn/\ncp ${PROJECT_DIR}/../../QTfrontend/res/icon*.png ${PROJECT_DIR}/Data/Graphics/Btn/\ncp ${PROJECT_DIR}/../../QTfrontend/res/StatsMedal*.png ${PROJECT_DIR}/Data/Graphics/Btn/\ncp ${PROJECT_DIR}/../../QTfrontend/res/StatsR.png ${PROJECT_DIR}/Data/Graphics/Btn/StatsStar.png\ncp ${PROJECT_DIR}/../../QTfrontend/res/ammopic.png ${PROJECT_DIR}/Data/Graphics/Btn/iconAmmo.png\ncp -R ${PROJECT_DIR}/../../QTfrontend/res/botlevels ${PROJECT_DIR}/Data/Graphics/Hedgehog/botlevels/\n\necho \"Removing text and dummy files...\"\n#delete all CMakeLists.txt and image source files\nfind ${PROJECT_DIR}/Data -name CMakeLists.txt -delete\nfind ${PROJECT_DIR}/Data -name *.svg -delete\nfind ${PROJECT_DIR}/Data -name *.svgz -delete\nfind ${PROJECT_DIR}/Data -name *.sifz -delete\nfind ${PROJECT_DIR}/Data -name *.xcf -delete\nfind ${PROJECT_DIR}/Data -name *.orig -delete\n\n#delete desktop frontend translation\nrm -rf ${PROJECT_DIR}/Data/Locale/hedgewars_*\n\n#delete dummy maps and hats, misc stuff\nrm -rf ${PROJECT_DIR}/Data/Maps/{test*,Ruler}\nrm -rf ${PROJECT_DIR}/Data/Graphics/Hats/{TeamCap,TeamHeadband,TeamHair}\nrm -rf ${PROJECT_DIR}/Data/misc/\n\n#delete forbidden maps\nrm -rf ${PROJECT_DIR}/Data/Maps/{Cheese,FlightJoust}\n\n#delete useless fonts\nrm -rf ${PROJECT_DIR}/Data/Fonts/{wqy-zenhei.ttc,DroidSansFallback.ttf}\n\n#delete all names, reserved hats\nrm -rf ${PROJECT_DIR}/Data/Names/\nrm -rf ${PROJECT_DIR}/Data/Graphics/Hats/Reserved/\n\necho \"Handling audio files...\"\n#delete the Classic voice\nrm -rf ${PROJECT_DIR}/Data/Sounds/voices/Classic\n#delete the main theme file\nrm -rf ${PROJECT_DIR}/Data/Music/main_theme.ogg\n#copy mono audio\ncp -R ${PROJECT_DIR}/Audio/* ${PROJECT_DIR}/Data/\n#remove unused voices\nfor i in {Amazing,Brilliant,Bugger,Bungee,Cutitout,Drat,Excellent,Fire,Gonnagetyou,Grenade,Hello,Hmm,Justyouwait,Leavemealone,Ohdear,Ouch,Perfect,Revenge,Runaway,Solong,Thisoneismine,Victory,Watchthis,Whatthe,Whoopsee}; do find Data/Sounds/voices/ -name $i.ogg -delete; done\n\necho \"Tweaking Data contents...\"\n#move Lua maps in Missions\nmkdir ${PROJECT_DIR}/Data/Missions/Maps/\nmv ${PROJECT_DIR}/Data/Maps/{Basketball,Knockball,TrophyRace,CTF_Blizzard,Control} ${PROJECT_DIR}/Data/Missions/Maps/\n#workaround for missing map in CTF_Blizzard\nln -s ../../../Maps/Blizzard/map.png ${PROJECT_DIR}/Data/Missions/Maps/CTF_Blizzard/map.png\n\n#reduce the number of flakes for City\nawk '{if ($1 == 1500) $1=40; print $0}' < ${PROJECT_DIR}/Data/Themes/City/theme.cfg > /tmp/tempfile\nmv /tmp/tempfile ${PROJECT_DIR}/Data/Themes/City/theme.cfg\n\n#remove Isalnd from the list of Themes\nawk '{if ($1 != \"Island\") print $0}' < ${PROJECT_DIR}/Data/Themes/themes.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Themes/themes.cfg\n\n#remove Beach and Digital themes as well as Islqnd (from Maps and Themes folders)\nrm -rf ${PROJECT_DIR}/Data/Themes/{Beach,Digital}\nrm -rf ${PROJECT_DIR}/Data/Themes/Island\nawk '{if ($1 == \"Island\") print \"Nature\"}' < ${PROJECT_DIR}/Data/Maps/Cave/map.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Maps/Cave/map.cfg\nawk '{if ($1 == \"Island\") print \"Nature\"}' < ${PROJECT_DIR}/Data/Maps/Lonely_Island/map.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Maps/Lonely_Island/map.cfg\nawk '{if ($1 == \"Island\") print \"Nature\"}' < ${PROJECT_DIR}/Data/Maps/PirateFlag/map.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Maps/PirateFlag/map.cfg\n\necho \"Done\""; + shellScript = "#copy new stuff over old stuff\nrm -rf ${PROJECT_DIR}/Data\n\n#create config.inc\necho \"Updating config file...\"\nPROTO=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep HEDGEWARS_PROTO_VER | cut -d ' ' -f 3`\nMAJN=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep CPACK_PACKAGE_VERSION_MAJOR | xargs | cut -d ' ' -f 3`\nMINN=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep CPACK_PACKAGE_VERSION_MINOR | xargs | cut -d ' ' -f 3`\nPATN=`cat ${PROJECT_DIR}/../../CMakeLists.txt | grep CPACK_PACKAGE_VERSION_PATCH | xargs | cut -d ' ' -f 3 | cut -d '$' -f 1`\nREVN=-`/usr/local/bin/hg id -n ${PROJECT_DIR}/../../`\necho \"const cNetProtoVersion = $PROTO; const cVersionString = '${MAJN}.${MINN}.${PATN}${REVN}'; const cLuaLibrary = '';\" > ${PROJECT_DIR}/../../hedgewars/config.inc\n\necho \"Copying Data...\"\ncp -R ${PROJECT_DIR}/../../share/hedgewars/Data ${PROJECT_DIR}/Data\n\n#copy some files from QTfrontend/res\necho \"Fetching additional graphics from QTfrontend/res...\"\nmkdir ${PROJECT_DIR}/Data/Graphics/Btn\ncp ${PROJECT_DIR}/../../QTfrontend/res/btn*.png ${PROJECT_DIR}/Data/Graphics/Btn/\ncp ${PROJECT_DIR}/../../QTfrontend/res/icon*.png ${PROJECT_DIR}/Data/Graphics/Btn/\ncp ${PROJECT_DIR}/../../QTfrontend/res/StatsMedal*.png ${PROJECT_DIR}/Data/Graphics/Btn/\ncp ${PROJECT_DIR}/../../QTfrontend/res/StatsR.png ${PROJECT_DIR}/Data/Graphics/Btn/StatsStar.png\ncp ${PROJECT_DIR}/../../QTfrontend/res/ammopic.png ${PROJECT_DIR}/Data/Graphics/Btn/iconAmmo.png\ncp -R ${PROJECT_DIR}/../../QTfrontend/res/botlevels ${PROJECT_DIR}/Data/Graphics/Hedgehog/botlevels/\n\necho \"Removing text and dummy files...\"\n#delete all CMakeLists.txt and image source files\nfind ${PROJECT_DIR}/Data -name CMakeLists.txt -delete\nfind ${PROJECT_DIR}/Data -name *.svg -delete\nfind ${PROJECT_DIR}/Data -name *.svgz -delete\nfind ${PROJECT_DIR}/Data -name *.sifz -delete\nfind ${PROJECT_DIR}/Data -name *.xcf -delete\nfind ${PROJECT_DIR}/Data -name *.orig -delete\n\n#delete desktop frontend translation\nrm -rf ${PROJECT_DIR}/Data/Locale/hedgewars_*\n\n#delete dummy maps and hats, misc stuff\nrm -rf ${PROJECT_DIR}/Data/Maps/{test*,Ruler}\nrm -rf ${PROJECT_DIR}/Data/Graphics/Hats/{TeamCap,TeamHeadband,TeamHair}\nrm -rf ${PROJECT_DIR}/Data/misc/\n\n#delete forbidden maps\nrm -rf ${PROJECT_DIR}/Data/Maps/{Cheese,FlightJoust}\n\n#delete useless fonts\nrm -rf ${PROJECT_DIR}/Data/Fonts/{wqy-zenhei.ttc,DroidSansFallback.ttf}\n\n#delete all names, reserved hats\nrm -rf ${PROJECT_DIR}/Data/Names/\nrm -rf ${PROJECT_DIR}/Data/Graphics/Hats/Reserved/\n\necho \"Handling audio files...\"\n#delete the Classic voice\nrm -rf ${PROJECT_DIR}/Data/Sounds/voices/Classic\n#delete the main theme file\nrm -rf ${PROJECT_DIR}/Data/Music/main_theme.ogg\n#copy mono audio\ncp -R ${PROJECT_DIR}/Audio/* ${PROJECT_DIR}/Data/\n#remove unused voices\nfor i in {Amazing,Brilliant,Bugger,Bungee,Cutitout,Drat,Excellent,Fire,FlawlessPossibility,Gonnagetyou,Grenade,Hmm,Justyouwait,Leavemealone,Ohdear,Ouch,Perfect,Revenge,Runaway,Solong,Thisoneismine,VictoryPossibility,Watchthis,Whatthe,Whoopsee}; do find Data/Sounds/voices/ -name $i.ogg -delete; done\n\necho \"Tweaking Data contents...\"\n#move Lua maps in Missions\nmkdir ${PROJECT_DIR}/Data/Missions/Maps/\nmv ${PROJECT_DIR}/Data/Maps/{Basketball,Knockball,TrophyRace,CTF_Blizzard,Control} ${PROJECT_DIR}/Data/Missions/Maps/\n#workaround for missing map in CTF_Blizzard\nln -s ../../../Maps/Blizzard/map.png ${PROJECT_DIR}/Data/Missions/Maps/CTF_Blizzard/map.png\n\n#reduce the number of flakes for City\nawk '{if ($1 == 1500) $1=40; print $0}' < ${PROJECT_DIR}/Data/Themes/City/theme.cfg > /tmp/tempfile\nmv /tmp/tempfile ${PROJECT_DIR}/Data/Themes/City/theme.cfg\n\n#remove Isalnd from the list of Themes\nawk '{if ($1 != \"Island\") print $0}' < ${PROJECT_DIR}/Data/Themes/themes.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Themes/themes.cfg\n\n#remove Beach and Digital themes as well as Islqnd (from Maps and Themes folders)\nrm -rf ${PROJECT_DIR}/Data/Themes/{Beach,Digital}\nrm -rf ${PROJECT_DIR}/Data/Themes/Island\nawk '{if ($1 == \"Island\") print \"Nature\"}' < ${PROJECT_DIR}/Data/Maps/Cave/map.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Maps/Cave/map.cfg\nawk '{if ($1 == \"Island\") print \"Nature\"}' < ${PROJECT_DIR}/Data/Maps/Lonely_Island/map.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Maps/Lonely_Island/map.cfg\nawk '{if ($1 == \"Island\") print \"Nature\"}' < ${PROJECT_DIR}/Data/Maps/PirateFlag/map.cfg > /tmp/tempfile && mv /tmp/tempfile ${PROJECT_DIR}/Data/Maps/PirateFlag/map.cfg\n\necho \"Done\""; showEnvVarsInLog = 0; }; 9283011B0F10CB2D00CC5A3C /* Build libfpc.a */ = {