Mercurial Mercurial > hedgewars / comparison
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | file | latest | revisions | annotate | diff | comparison | raw | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gameServer/Actions.hs
changeset 3425 ead2ed20dfd4
parent 3283 18ee933a5864
child 3435 4e4f88a7bdf2
equal deleted inserted replaced
3424:5543340db663 3425:ead2ed20dfd4 
     1 module Actions where
 
     1 module Actions where
 
     2 
     2 
       
     3 import Control.Concurrent
 
     3 import Control.Concurrent.STM
 
     4 import Control.Concurrent.STM
 
     4 import Control.Concurrent.Chan
 
     5 import Control.Concurrent.Chan
 
     5 import Data.IntMap
 
       
     6 import qualified Data.IntSet as IntSet
 
     6 import qualified Data.IntSet as IntSet
 
     7 import qualified Data.Sequence as Seq
 
     7 import qualified Data.Sequence as Seq
 
     8 import System.Log.Logger
 
     8 import System.Log.Logger
 
     9 import Monad
 
     9 import Monad
 
    10 import Data.Time
 
    10 import Data.Time
 
    11 import Maybe
 
    11 import Maybe
 
       
    12 
    12 -----------------------------
 
    13 -----------------------------
 
    13 import CoreTypes
 
    14 import CoreTypes
 
    14 import Utils
 
    15 import Utils
 
       
    16 import ClientIO
 
       
    17 import RoomsAndClients
 
    15 
    18 
    16 data Action =
 
    19 data Action =
 
    17     AnswerThisClient [String]
 
    20     AnswerClients [Chan [String]] [String]
 
    18     | AnswerAll [String]
 
       
    19     | AnswerAllOthers [String]
 
       
    20     | AnswerThisRoom [String]
 
       
    21     | AnswerOthersInRoom [String]
 
       
    22     | AnswerSameClan [String]
 
       
    23     | AnswerLobby [String]
 
       
    24     | SendServerMessage
 
    21     | SendServerMessage
 
    25     | SendServerVars
 
    22     | SendServerVars
 
    26     | RoomAddThisClient Int -- roomID
 
    23     | RoomAddThisClient Int -- roomID
 
    27     | RoomRemoveThisClient String
 
    24     | RoomRemoveThisClient String
 
    28     | RemoveTeam String
 
    25     | RemoveTeam String
 
    47     | Dump
 
    44     | Dump
 
    48     | AddClient ClientInfo
 
    45     | AddClient ClientInfo
 
    49     | PingAll
 
    46     | PingAll
 
    50     | StatsAction
 
    47     | StatsAction
 
    51 
    48 
    52 type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
 
    49 type CmdHandler = Int -> MRnC -> [String] -> [Action]
 
    53 
    50 
    54 replaceID a (b, c, d, e) = (a, c, d, e)
 
    51 replaceID a (b, c, d, e) = (a, c, d, e)
 
    55 
    52 
    56 processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
 
    53 processAction :: (ClientIndex, ServerInfo, MRnC) -> Action -> IO (ClientIndex, ServerInfo)
 
    57 
    54 
    58 
    55 
    59 processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
 
    56 processAction (ci, serverInfo, rnc) (AnswerClients chans msg) = do
 
    60     writeChan (sendChan $ clients ! clID) msg
 
    57     mapM_ (flip writeChan msg) chans
 
    61     return (clID, serverInfo, clients, rooms)
 
    58     return (ci, serverInfo)
 
    62 
    59 
    63 
    60 
    64 processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
 
    61 {-
 
    65     mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)
 
    62 processAction (clID, serverInfo, rnc) SendServerMessage = do
 
    66     return (clID, serverInfo, clients, rooms)
 
       
    67 
       
    68 
       
    69 processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do
 
       
    70     mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $
 
       
    71         Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients)
 
       
    72     return (clID, serverInfo, clients, rooms)
 
       
    73 
       
    74 
       
    75 processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
 
       
    76     mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
 
       
    77     return (clID, serverInfo, clients, rooms)
 
       
    78     where
 
       
    79         roomClients = IntSet.elems $ playersIDs room
 
       
    80         room = rooms ! rID
 
       
    81         rID = roomID client
 
       
    82         client = clients ! clID
 
       
    83 
       
    84 
       
    85 processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do
 
       
    86     mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients
 
       
    87     return (clID, serverInfo, clients, rooms)
 
       
    88     where
 
       
    89         roomClients = IntSet.elems $ playersIDs room
 
       
    90         room = rooms ! rID
 
       
    91         rID = roomID client
 
       
    92         client = clients ! clID
 
       
    93 
       
    94 
       
    95 processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
 
       
    96     mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
 
       
    97     return (clID, serverInfo, clients, rooms)
 
       
    98     where
 
       
    99         roomClients = IntSet.elems $ playersIDs room
 
       
   100         room = rooms ! 0
 
       
   101 
       
   102 
       
   103 processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do
 
       
   104     mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec
 
       
   105     return (clID, serverInfo, clients, rooms)
 
       
   106     where
 
       
   107         otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room)
 
       
   108         sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators
 
       
   109         spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients
 
       
   110         sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients
 
       
   111         thisClan = clientClan client
 
       
   112         room = rooms ! rID
 
       
   113         rID = roomID client
 
       
   114         client = clients ! clID
 
       
   115 
       
   116 
       
   117 processAction (clID, serverInfo, clients, rooms) SendServerMessage = do
 
       
   118     writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
 
    63     writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
 
   119     return (clID, serverInfo, clients, rooms)
 
    64     return (clID, serverInfo, rnc)
 
   120     where
 
    65     where
 
   121         client = clients ! clID
 
    66         client = clients ! clID
 
   122         message si = if clientProto client < latestReleaseVersion si then
 
    67         message si = if clientProto client < latestReleaseVersion si then
 
   123             serverMessageForOldVersions si
 
    68             serverMessageForOldVersions si
 
   124             else
 
    69             else
 
   125             serverMessage si
 
    70             serverMessage si
 
   126 
    71 
   127 processAction (clID, serverInfo, clients, rooms) SendServerVars = do
 
    72 processAction (clID, serverInfo, rnc) SendServerVars = do
 
   128     writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
 
    73     writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
 
   129     return (clID, serverInfo, clients, rooms)
 
    74     return (clID, serverInfo, rnc)
 
   130     where
 
    75     where
 
   131         client = clients ! clID
 
    76         client = clients ! clID
 
   132         vars = [
 
    77         vars = [
 
   133             "MOTD_NEW", serverMessage serverInfo, 
    78             "MOTD_NEW", serverMessage serverInfo,
 
   134             "MOTD_OLD", serverMessageForOldVersions serverInfo, 
    79             "MOTD_OLD", serverMessageForOldVersions serverInfo,
 
   135             "LATEST_PROTO", show $ latestReleaseVersion serverInfo
 
    80             "LATEST_PROTO", show $ latestReleaseVersion serverInfo
 
   136             ]
 
    81             ]
 
   137 
    82 
   138 
    83 
   139 processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
 
    84 processAction (clID, serverInfo, rnc) (ProtocolError msg) = do
 
   140     writeChan (sendChan $ clients ! clID) ["ERROR", msg]
 
    85     writeChan (sendChan $ clients ! clID) ["ERROR", msg]
 
   141     return (clID, serverInfo, clients, rooms)
 
    86     return (clID, serverInfo, rnc)
 
   142 
    87 
   143 
    88 
   144 processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
 
    89 processAction (clID, serverInfo, rnc) (Warning msg) = do
 
   145     writeChan (sendChan $ clients ! clID) ["WARNING", msg]
 
    90     writeChan (sendChan $ clients ! clID) ["WARNING", msg]
 
   146     return (clID, serverInfo, clients, rooms)
 
    91     return (clID, serverInfo, rnc)
 
   147 
    92 
   148 
    93 
   149 processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do
 
    94 processAction (clID, serverInfo, rnc) (ByeClient msg) = do
 
   150     infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg)
 
    95     infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg)
 
   151     (_, _, newClients, newRooms) <-
 
    96     (_, _, newClients, newRooms) <-
 
   152             if roomID client /= 0 then
 
    97             if roomID client /= 0 then
 
   153                 processAction  (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit"
 
    98                 processAction  (clID, serverInfo, rnc) $ RoomRemoveThisClient "quit"
 
   154                 else
 
    99                 else
 
   155                     return (clID, serverInfo, clients, rooms)
 
   100                     return (clID, serverInfo, rnc)
 
   156 
   101 
   157     mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom
 
   102     mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom
 
   158     writeChan (sendChan $ clients ! clID) ["BYE", msg]
 
   103     writeChan (sendChan $ clients ! clID) ["BYE", msg]
 
   159     return (
 
   104     return (
 
   160             0,
 
   105             0,
 
   185                     [AnswerAll ["LOBBY:LEFT", clientNick]]
 
   130                     [AnswerAll ["LOBBY:LEFT", clientNick]]
 
   186             else
 
   131             else
 
   187                 []
 
   132                 []
 
   188 
   133 
   189 
   134 
   190 processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
 
   135 processAction (clID, serverInfo, rnc) (ModifyClient func) =
 
   191     return (clID, serverInfo, adjust func clID clients, rooms)
 
   136     return (clID, serverInfo, adjust func clID rnc)
 
   192 
   137 
   193 
   138 
   194 processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
 
   139 processAction (clID, serverInfo, rnc) (ModifyClient2 cl2ID func) =
 
   195     return (clID, serverInfo, adjust func cl2ID clients, rooms)
 
   140     return (clID, serverInfo, adjust func cl2ID rnc)
 
   196 
   141 
   197 
   142 
   198 processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
 
   143 processAction (clID, serverInfo, rnc) (ModifyRoom func) =
 
   199     return (clID, serverInfo, clients, adjust func rID rooms)
 
   144     return (clID, serverInfo, clients, adjust func rID rooms)
 
   200     where
 
   145     where
 
   201         rID = roomID $ clients ! clID
 
   146         rID = roomID $ clients ! clID
 
   202 
   147 
   203 
   148 
   204 processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
 
   149 processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
 
   205     return (clID, func serverInfo, clients, rooms)
 
   150     return (clID, func serverInfo, rnc)
 
   206 
   151 
   207 
   152 
   208 processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) =
 
   153 processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
 
   209     processAction (
 
   154     processAction (
 
   210         clID,
 
   155         clID,
 
   211         serverInfo,
 
   156         serverInfo,
 
   212         adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
 
   157         adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
 
   213         adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
 
   158         adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
 
   219                 AnswerAllOthers ["LOBBY:JOINED", nick client]
 
   164                 AnswerAllOthers ["LOBBY:JOINED", nick client]
 
   220             else
 
   165             else
 
   221                 AnswerThisRoom ["JOINED", nick client]
 
   166                 AnswerThisRoom ["JOINED", nick client]
 
   222 
   167 
   223 
   168 
   224 processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do
 
   169 processAction (clID, serverInfo, rnc) (RoomRemoveThisClient msg) = do
 
   225     (_, _, newClients, newRooms) <-
 
   170     (_, _, newClients, newRooms) <-
 
   226         if roomID client /= 0 then
 
   171         if roomID client /= 0 then
 
   227             if isMaster client then
 
   172             if isMaster client then
 
   228                 if (gameinprogress room) && (playersIn room > 1) then
 
   173                 if (gameinprogress room) && (playersIn room > 1) then
 
   229                     (changeMaster >>= (\state -> foldM processAction state
 
   174                     (changeMaster >>= (\state -> foldM processAction state
 
   230                         [AnswerOthersInRoom ["LEFT", nick client, msg],
 
   175                         [AnswerOthersInRoom ["LEFT", nick client, msg],
 
   231                         AnswerOthersInRoom ["WARNING", "Admin left the room"],
 
   176                         AnswerOthersInRoom ["WARNING", "Admin left the room"],
 
   232                         RemoveClientTeams clID]))
 
   177                         RemoveClientTeams clID]))
 
   233                 else -- not in game
 
   178                 else -- not in game
 
   234                     processAction (clID, serverInfo, clients, rooms) RemoveRoom
 
   179                     processAction (clID, serverInfo, rnc) RemoveRoom
 
   235             else -- not master
 
   180             else -- not master
 
   236                 foldM
 
   181                 foldM
 
   237                     processAction
 
   182                     processAction
 
   238                         (clID, serverInfo, clients, rooms)
 
   183                         (clID, serverInfo, rnc)
 
   239                         [AnswerOthersInRoom ["LEFT", nick client, msg],
 
   184                         [AnswerOthersInRoom ["LEFT", nick client, msg],
 
   240                         RemoveClientTeams clID]
 
   185                         RemoveClientTeams clID]
 
   241         else -- in lobby
 
   186         else -- in lobby
 
   242             return (clID, serverInfo, clients, rooms)
 
   187             return (clID, serverInfo, rnc)
 
   243     
   188 
   244     return (
 
   189     return (
 
   245         clID,
 
   190         clID,
 
   246         serverInfo,
 
   191         serverInfo,
 
   247         adjust resetClientFlags clID newClients,
 
   192         adjust resetClientFlags clID newClients,
 
   248         adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
 
   193         adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
 
   257                 playersIn = (playersIn r) - 1,
 
   202                 playersIn = (playersIn r) - 1,
 
   258                 readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
 
   203                 readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
 
   259                 }
 
   204                 }
 
   260         insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
 
   205         insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
 
   261         changeMaster = do
 
   206         changeMaster = do
 
   262             processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
 
   207             processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
 
   263             return (
 
   208             return (
 
   264                 clID,
 
   209                 clID,
 
   265                 serverInfo,
 
   210                 serverInfo,
 
   266                 adjust (\cl -> cl{isMaster = True}) newMasterId clients,
 
   211                 adjust (\cl -> cl{isMaster = True}) newMasterId clients,
 
   267                 adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
 
   212                 adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
 
   270         otherPlayersSet = IntSet.delete clID (playersIDs room)
 
   215         otherPlayersSet = IntSet.delete clID (playersIDs room)
 
   271         newMasterId = IntSet.findMin otherPlayersSet
 
   216         newMasterId = IntSet.findMin otherPlayersSet
 
   272         newMasterClient = clients ! newMasterId
 
   217         newMasterClient = clients ! newMasterId
 
   273 
   218 
   274 
   219 
   275 processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
 
   220 processAction (clID, serverInfo, rnc) (AddRoom roomName roomPassword) = do
 
   276     let newServerInfo = serverInfo {nextRoomID = newID}
 
   221     let newServerInfo = serverInfo {nextRoomID = newID}
 
   277     let room = newRoom{
 
   222     let room = newRoom{
 
   278             roomUID = newID,
 
   223             roomUID = newID,
 
   279             masterID = clID,
 
   224             masterID = clID,
 
   280             name = roomName,
 
   225             name = roomName,
 
   281             password = roomPassword,
 
   226             password = roomPassword,
 
   282             roomProto = (clientProto client)
 
   227             roomProto = (clientProto client)
 
   283             }
 
   228             }
 
   284 
   229 
   285     processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
 
   230     processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "ADD", roomName]
 
   286 
   231 
   287     processAction (
 
   232     processAction (
 
   288         clID,
 
   233         clID,
 
   289         newServerInfo,
 
   234         newServerInfo,
 
   290         adjust (\cl -> cl{isMaster = True}) clID clients,
 
   235         adjust (\cl -> cl{isMaster = True}) clID clients,
 
   293     where
 
   238     where
 
   294         newID = (nextRoomID serverInfo) - 1
 
   239         newID = (nextRoomID serverInfo) - 1
 
   295         client = clients ! clID
 
   240         client = clients ! clID
 
   296 
   241 
   297 
   242 
   298 processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do
 
   243 processAction (clID, serverInfo, rnc) (RemoveRoom) = do
 
   299     processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room]
 
   244     processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room]
 
   300     processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
 
   245     processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
 
   301     return (clID,
 
   246     return (clID,
 
   302         serverInfo,
 
   247         serverInfo,
 
   303         Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
 
   248         Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
 
   304         delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
 
   249         delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
 
   305         )
 
   250         )
 
   307         room = rooms ! rID
 
   252         room = rooms ! rID
 
   308         rID = roomID client
 
   253         rID = roomID client
 
   309         client = clients ! clID
 
   254         client = clients ! clID
 
   310 
   255 
   311 
   256 
   312 processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do
 
   257 processAction (clID, serverInfo, rnc) (UnreadyRoomClients) = do
 
   313     processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
 
   258     processAction (clID, serverInfo, rnc) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
 
   314     return (clID,
 
   259     return (clID,
 
   315         serverInfo,
 
   260         serverInfo,
 
   316         Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
 
   261         Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
 
   317         adjust (\r -> r{readyPlayers = 0}) rID rooms)
 
   262         adjust (\r -> r{readyPlayers = 0}) rID rooms)
 
   318     where
 
   263     where
 
   321         client = clients ! clID
 
   266         client = clients ! clID
 
   322         roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
 
   267         roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
 
   323         roomPlayersIDs = IntSet.elems $ playersIDs room
 
   268         roomPlayersIDs = IntSet.elems $ playersIDs room
 
   324 
   269 
   325 
   270 
   326 processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do
 
   271 processAction (clID, serverInfo, rnc) (RemoveTeam teamName) = do
 
   327     newRooms <- if not $ gameinprogress room then
 
   272     newRooms <- if not $ gameinprogress room then
 
   328             do
 
   273             do
 
   329             processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
 
   274             processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
 
   330             return $
 
   275             return $
 
   331                 adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
 
   276                 adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
 
   332         else
 
   277         else
 
   333             do
 
   278             do
 
   334             processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg]
 
   279             processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["EM", rmTeamMsg]
 
   335             return $
 
   280             return $
 
   336                 adjust (\r -> r{
 
   281                 adjust (\r -> r{
 
   337                 teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
 
   282                 teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
 
   338                 leftTeams = teamName : leftTeams r,
 
   283                 leftTeams = teamName : leftTeams r,
 
   339                 roundMsgs = roundMsgs r Seq.|> rmTeamMsg
 
   284                 roundMsgs = roundMsgs r Seq.|> rmTeamMsg
 
   344         rID = roomID client
 
   289         rID = roomID client
 
   345         client = clients ! clID
 
   290         client = clients ! clID
 
   346         rmTeamMsg = toEngineMsg $ 'F' : teamName
 
   291         rmTeamMsg = toEngineMsg $ 'F' : teamName
 
   347 
   292 
   348 
   293 
   349 processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do
 
   294 processAction (clID, serverInfo, rnc) (CheckRegistered) = do
 
   350     writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
 
   295     writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
 
   351     return (clID, serverInfo, clients, rooms)
 
   296     return (clID, serverInfo, rnc)
 
   352     where
 
   297     where
 
   353         client = clients ! clID
 
   298         client = clients ! clID
 
   354 
   299 
   355 
   300 
   356 processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do
 
   301 processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do
 
   357     writeChan (dbQueries serverInfo) ClearCache
 
   302     writeChan (dbQueries serverInfo) ClearCache
 
   358     return (clID, serverInfo, clients, rooms)
 
   303     return (clID, serverInfo, rnc)
 
   359     where
 
   304     where
 
   360         client = clients ! clID
 
   305         client = clients ! clID
 
   361 
   306 
   362 
   307 
   363 processAction (clID, serverInfo, clients, rooms) (Dump) = do
 
   308 processAction (clID, serverInfo, rnc) (Dump) = do
 
   364     writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
 
   309     writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
 
   365     return (clID, serverInfo, clients, rooms)
 
   310     return (clID, serverInfo, rnc)
 
   366 
   311 
   367 
   312 
   368 processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
 
   313 processAction (clID, serverInfo, rnc) (ProcessAccountInfo info) =
 
   369     case info of
 
   314     case info of
 
   370         HasAccount passwd isAdmin -> do
 
   315         HasAccount passwd isAdmin -> do
 
   371             infoM "Clients" $ show clID ++ " has account"
 
   316             infoM "Clients" $ show clID ++ " has account"
 
   372             writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
 
   317             writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
 
   373             return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms)
 
   318             return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID rnc)
 
   374         Guest -> do
 
   319         Guest -> do
 
   375             infoM "Clients" $ show clID ++ " is guest"
 
   320             infoM "Clients" $ show clID ++ " is guest"
 
   376             processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
 
   321             processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID rnc) MoveToLobby
 
   377         Admin -> do
 
   322         Admin -> do
 
   378             infoM "Clients" $ show clID ++ " is admin"
 
   323             infoM "Clients" $ show clID ++ " is admin"
 
   379             foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
 
   324             foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID rnc) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
 
   380 
   325 
   381 
   326 
   382 processAction (clID, serverInfo, clients, rooms) (MoveToLobby) =
 
   327 processAction (clID, serverInfo, rnc) (MoveToLobby) =
 
   383     foldM processAction (clID, serverInfo, clients, rooms) $
 
   328     foldM processAction (clID, serverInfo, rnc) $
 
   384         (RoomAddThisClient 0)
 
   329         (RoomAddThisClient 0)
 
   385         : answerLobbyNicks
 
   330         : answerLobbyNicks
 
   386         ++ [SendServerMessage]
 
   331         ++ [SendServerMessage]
 
   387 
   332 
   388         -- ++ (answerServerMessage client clients)
 
   333         -- ++ (answerServerMessage client clients)
 
   389     where
 
   334     where
 
   390         lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
 
   335         lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
 
   391         answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
 
   336         answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
 
   392 
   337 
   393 
   338 
   394 processAction (clID, serverInfo, clients, rooms) (KickClient kickID) =
 
   339 processAction (clID, serverInfo, rnc) (KickClient kickID) =
 
   395     liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")
 
   340     liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
 
   396 
   341 
   397 
   342 
   398 processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
 
   343 processAction (clID, serverInfo, rnc) (BanClient banNick) =
 
   399     return (clID, serverInfo, clients, rooms)
 
   344     return (clID, serverInfo, rnc)
 
   400 
   345 
   401 
   346 
   402 processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do
 
   347 processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do
 
   403     writeChan (sendChan $ clients ! kickID) ["KICKED"]
 
   348     writeChan (sendChan $ clients ! kickID) ["KICKED"]
 
   404     liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")
 
   349     liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
 
   405 
   350 
   406 
   351 
   407 processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
 
   352 processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) =
 
   408     liftM2 replaceID (return clID) $
 
   353     liftM2 replaceID (return clID) $
 
   409         foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions
 
   354         foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions
 
   410     where
 
   355     where
 
   411         client = clients ! teamsClID
 
   356         client = clients ! teamsClID
 
   412         room = rooms ! (roomID client)
 
   357         room = rooms ! (roomID client)
 
   413         teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
 
   358         teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
 
   414         removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
 
   359         removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
 
   415 
   360 
   416 
   361 
   417 processAction (clID, serverInfo, clients, rooms) (AddClient client) = do
 
   362 processAction (clID, serverInfo, rnc) (AddClient client) = do
 
       
   363     forkIO $ clientRecvLoop (clientHandle client) (coreChan serverInfo) (clientUID client)
 
       
   364     forkIO $ clientSendLoop (clientHandle client) (coreChan serverInfo) (sendChan client) (clientUID client)
 
       
   365 
   418     let updatedClients = insert (clientUID client) client clients
 
   366     let updatedClients = insert (clientUID client) client clients
 
   419     infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client))
 
   367     infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client))
 
   420     writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
 
   368     writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
 
   421 
   369 
   422     let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
 
   370     let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
 
   423 
   371 
   424     if isJust $ host client `Prelude.lookup` newLogins then
 
   372     if False && (isJust $ host client `Prelude.lookup` newLogins) then
 
   425         processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"
 
   373         processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"
 
   426         else
 
   374         else
 
   427         return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)
 
   375         return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)
 
   428 
   376 
   429 
   377 
   430 processAction (clID, serverInfo, clients, rooms) PingAll = do
 
   378 processAction (clID, serverInfo, rnc) PingAll = do
 
   431     (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients
 
   379     (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, rnc) $ elems clients
 
   432     processAction (clID,
 
   380     processAction (clID,
 
   433         serverInfo,
 
   381         serverInfo,
 
   434         Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
 
   382         Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
 
   435         newRooms) $ AnswerAll ["PING"]
 
   383         newRooms) $ AnswerAll ["PING"]
 
   436     where
 
   384     where
 
   437         kickTimeouted (clID, serverInfo, clients, rooms) client =
 
   385         kickTimeouted (clID, serverInfo, rnc) client =
 
   438             if pingsQueue client > 0 then
 
   386             if pingsQueue client > 0 then
 
   439                 processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout"
 
   387                 processAction (clientUID client, serverInfo, rnc) $ ByeClient "Ping timeout"
 
   440                 else
 
   388                 else
 
   441                 return (clID, serverInfo, clients, rooms)
 
   389                 return (clID, serverInfo, rnc)
 
   442 
   390 
   443 
   391 
   444 processAction (clID, serverInfo, clients, rooms) (StatsAction) = do
 
   392 processAction (clID, serverInfo, rnc) (StatsAction) = do
 
   445     writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
 
   393     writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
 
   446     return (clID, serverInfo, clients, rooms)
 
   394     return (clID, serverInfo, rnc)
 
       
   395 
       
   396 -}
hedgewars