gameServer/Actions.hs
changeset 4932 f11d80bac7ed
parent 4923 c7829611c682
child 4942 1c85a8e6e11c
equal deleted inserted replaced
4931:da43c36a6e92 4932:f11d80bac7ed
     1 {-# LANGUAGE OverloadedStrings #-}
     1 {-# LANGUAGE OverloadedStrings #-}
     2 module Actions where
     2 module Actions where
     3 
     3 
     4 import Control.Concurrent
     4 import Control.Concurrent
     5 import Control.Concurrent.Chan
       
     6 import qualified Data.IntSet as IntSet
       
     7 import qualified Data.Set as Set
     5 import qualified Data.Set as Set
     8 import qualified Data.Sequence as Seq
     6 import qualified Data.Sequence as Seq
     9 import System.Log.Logger
     7 import System.Log.Logger
    10 import Control.Monad
     8 import Control.Monad
    11 import Data.Time
     9 import Data.Time
    12 import Data.Maybe
    10 import Data.Maybe
    13 import Control.Monad.Reader
    11 import Control.Monad.Reader
    14 import Control.Monad.State.Strict
    12 import Control.Monad.State.Strict
    15 import qualified Data.ByteString.Char8 as B
    13 import qualified Data.ByteString.Char8 as B
    16 import Control.DeepSeq
    14 import Control.DeepSeq
    17 import Data.Time
       
    18 import Text.Printf
       
    19 import Data.Unique
    15 import Data.Unique
       
    16 import Control.Arrow
    20 -----------------------------
    17 -----------------------------
    21 import CoreTypes
    18 import CoreTypes
    22 import Utils
    19 import Utils
    23 import ClientIO
    20 import ClientIO
    24 import ServerState
    21 import ServerState
    63     rnf a = a `seq` ()
    60     rnf a = a `seq` ()
    64 
    61 
    65 instance NFData B.ByteString
    62 instance NFData B.ByteString
    66 instance NFData (Chan a)
    63 instance NFData (Chan a)
    67 
    64 
       
    65 
       
    66 othersChans :: StateT ServerState IO [ClientChan]
    68 othersChans = do
    67 othersChans = do
    69     cl <- client's id
    68     cl <- client's id
    70     ri <- clientRoomA
    69     ri <- clientRoomA
    71     liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
    70     liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
    72 
    71 
    73 processAction :: Action -> StateT ServerState IO ()
    72 processAction :: Action -> StateT ServerState IO ()
    74 
    73 
    75 
    74 
    76 processAction (AnswerClients chans msg) = do
    75 processAction (AnswerClients chans msg) =
    77     io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans)
    76     io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
    78 
    77 
    79 
    78 
    80 processAction SendServerMessage = do
    79 processAction SendServerMessage = do
    81     chan <- client's sendChan
    80     chan <- client's sendChan
    82     protonum <- client's clientProto
    81     protonum <- client's clientProto
   113     chan <- client's sendChan
   112     chan <- client's sendChan
   114     processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
   113     processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
   115 
   114 
   116 processAction (ByeClient msg) = do
   115 processAction (ByeClient msg) = do
   117     (Just ci) <- gets clientIndex
   116     (Just ci) <- gets clientIndex
   118     rnc <- gets roomsClients
       
   119     ri <- clientRoomA
   117     ri <- clientRoomA
   120 
   118 
   121     chan <- client's sendChan
   119     chan <- client's sendChan
   122     clNick <- client's nick
   120     clNick <- client's nick
   123 
   121 
   124     when (ri /= lobbyId) $ do
   122     when (ri /= lobbyId) $ do
   125         processAction $ MoveToLobby ("quit: " `B.append` msg)
   123         processAction $ MoveToLobby ("quit: " `B.append` msg)
   126         return ()
   124         return ()
   127 
   125 
   128     clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
   126     clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
   129     io $ do
   127     io $
   130         infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
   128         infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
   131 
   129 
   132     processAction $ AnswerClients [chan] ["BYE", msg]
   130     processAction $ AnswerClients [chan] ["BYE", msg]
   133     processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
   131     processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
   134 
   132 
   135     s <- get
   133     s <- get
   169     (Just ci) <- gets clientIndex
   167     (Just ci) <- gets clientIndex
   170     rnc <- gets roomsClients
   168     rnc <- gets roomsClients
   171 
   169 
   172     io $ do
   170     io $ do
   173         modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
   171         modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
   174         modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri
   172         modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
   175         moveClientToRoom rnc ri ci
   173         moveClientToRoom rnc ri ci
   176 
   174 
   177     chans <- liftM (map sendChan) $ roomClientsS ri
   175     chans <- liftM (map sendChan) $ roomClientsS ri
   178     clNick <- client's nick
   176     clNick <- client's nick
   179 
   177 
   182 
   180 
   183 processAction (MoveToLobby msg) = do
   181 processAction (MoveToLobby msg) = do
   184     (Just ci) <- gets clientIndex
   182     (Just ci) <- gets clientIndex
   185     ri <- clientRoomA
   183     ri <- clientRoomA
   186     rnc <- gets roomsClients
   184     rnc <- gets roomsClients
   187     (gameProgress, playersNum) <- io $ room'sM rnc (\r -> (gameinprogress r, playersIn r)) ri
   185     (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri
   188     ready <- client's isReady
   186     ready <- client's isReady
   189     master <- client's isMaster
   187     master <- client's isMaster
   190 --    client <- client's id
   188 --    client <- client's id
   191     clNick <- client's nick
   189     clNick <- client's nick
   192     chans <- othersChans
   190     chans <- othersChans
   199         else
   197         else
   200         mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
   198         mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
   201 
   199 
   202     io $ do
   200     io $ do
   203             modifyRoom rnc (\r -> r{
   201             modifyRoom rnc (\r -> r{
   204                     playersIn = (playersIn r) - 1,
   202                     playersIn = playersIn r - 1,
   205                     readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
   203                     readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
   206                     }) ri
   204                     }) ri
   207             moveClientToLobby rnc ci
   205             moveClientToLobby rnc ci
   208 
   206 
   209 processAction ChangeMaster = do
   207 processAction ChangeMaster = do
   221 processAction (AddRoom roomName roomPassword) = do
   219 processAction (AddRoom roomName roomPassword) = do
   222     Just clId <- gets clientIndex
   220     Just clId <- gets clientIndex
   223     rnc <- gets roomsClients
   221     rnc <- gets roomsClients
   224     proto <- io $ client'sM rnc clientProto clId
   222     proto <- io $ client'sM rnc clientProto clId
   225 
   223 
   226     let room = newRoom{
   224     let rm = newRoom{
   227             masterID = clId,
   225             masterID = clId,
   228             name = roomName,
   226             name = roomName,
   229             password = roomPassword,
   227             password = roomPassword,
   230             roomProto = proto
   228             roomProto = proto
   231             }
   229             }
   232 
   230 
   233     rId <- io $ addRoom rnc room
   231     rId <- io $ addRoom rnc rm
   234 
   232 
   235     processAction $ MoveToRoom rId
   233     processAction $ MoveToRoom rId
   236 
   234 
   237     chans <- liftM (map sendChan) $! roomClientsS lobbyId
   235     chans <- liftM (map sendChan) $! roomClientsS lobbyId
   238 
   236 
   268     processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
   266     processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
   269 
   267 
   270 
   268 
   271 processAction (RemoveTeam teamName) = do
   269 processAction (RemoveTeam teamName) = do
   272     rnc <- gets roomsClients
   270     rnc <- gets roomsClients
   273     cl <- client's id
       
   274     ri <- clientRoomA
   271     ri <- clientRoomA
   275     inGame <- io $ room'sM rnc gameinprogress ri
   272     inGame <- io $ room'sM rnc gameinprogress ri
   276     chans <- othersChans
   273     chans <- othersChans
   277     if inGame then
   274     if inGame then
   278             mapM_ processAction [
   275             mapM_ processAction [
   287                     leftTeams = teamName : leftTeams r,
   284                     leftTeams = teamName : leftTeams r,
   288                     roundMsgs = roundMsgs r Seq.|> rmTeamMsg
   285                     roundMsgs = roundMsgs r Seq.|> rmTeamMsg
   289                     })
   286                     })
   290                 ]
   287                 ]
   291     where
   288     where
   292         rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
   289         rmTeamMsg = toEngineMsg $ B.singleton 'F' `B.append` teamName
   293 
   290 
   294 
   291 
   295 processAction (RemoveClientTeams clId) = do
   292 processAction (RemoveClientTeams clId) = do
   296     rnc <- gets roomsClients
   293     rnc <- gets roomsClients
   297 
   294 
   324 processAction (ProcessAccountInfo info) =
   321 processAction (ProcessAccountInfo info) =
   325     case info of
   322     case info of
   326         HasAccount passwd isAdmin -> do
   323         HasAccount passwd isAdmin -> do
   327             chan <- client's sendChan
   324             chan <- client's sendChan
   328             mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
   325             mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
   329         Guest -> do
   326         Guest ->
   330             processAction JoinLobby
   327             processAction JoinLobby
   331         Admin -> do
   328         Admin -> do
   332             mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
   329             mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
   333             chan <- client's sendChan
   330             chan <- client's sendChan
   334             processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
   331             processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
   335 
   332 
   336 
   333 
   337 processAction JoinLobby = do
   334 processAction JoinLobby = do
   338     chan <- client's sendChan
   335     chan <- client's sendChan
   339     clientNick <- client's nick
   336     clientNick <- client's nick
   340     (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS
   337     (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS
   341     mapM_ processAction $
   338     mapM_ processAction $
   342         (AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
   339         AnswerClients clientsChans ["LOBBY:JOINED", clientNick]
   343         : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
   340         : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)
   344         ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
   341         : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
   345 
   342 
   346 {-
   343 {-
   347 processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
   344 processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
   348     processAction (
   345     processAction (
   349         clID,
   346         clID,
   365 
   362 
   366 
   363 
   367 processAction (BanClient seconds reason banId) = do
   364 processAction (BanClient seconds reason banId) = do
   368     modify (\s -> s{clientIndex = Just banId})
   365     modify (\s -> s{clientIndex = Just banId})
   369     clHost <- client's host
   366     clHost <- client's host
   370     currentTime <- io $ getCurrentTime
   367     currentTime <- io getCurrentTime
   371     let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` msg` B.append` ")"
   368     let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")"
   372     mapM_ processAction [
   369     mapM_ processAction [
   373         ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds $ currentTime, msg)) : lastLogins s})
   370         ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds currentTime, msg)) : lastLogins s})
   374         , KickClient banId
   371         , KickClient banId
   375         ]
   372         ]
   376 
   373 
   377 
   374 
   378 processAction (KickRoomClient kickId) = do
   375 processAction (KickRoomClient kickId) = do
   385     rnc <- gets roomsClients
   382     rnc <- gets roomsClients
   386     si <- gets serverInfo
   383     si <- gets serverInfo
   387     newClId <- io $ do
   384     newClId <- io $ do
   388         ci <- addClient rnc cl
   385         ci <- addClient rnc cl
   389         t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci
   386         t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci
   390         forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci
   387         _ <- forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci
   391 
   388 
   392         infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
   389         infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
   393 
   390 
   394         return ci
   391         return ci
   395 
   392 
   396     modify (\s -> s{clientIndex = Just newClId})
   393     modify (\s -> s{clientIndex = Just newClId})
   397     processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
   394     processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
   398 
   395 
   399     si <- gets serverInfo
   396     let newLogins = takeWhile (\(_ , (time, _)) -> connectTime cl `diffUTCTime` time <= 0) $ lastLogins si
   400     let newLogins = takeWhile (\(_ , (time, _)) -> (connectTime cl) `diffUTCTime` time <= 0) $ lastLogins si
       
   401     let info = host cl `Prelude.lookup` newLogins
   397     let info = host cl `Prelude.lookup` newLogins
   402     if isJust info then
   398     if isJust info then
   403         mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd .  fromJust $ info)]
   399         mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd .  fromJust $ info)]
   404         else
   400         else
   405         processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins})
   401         processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins})
   421 
   417 
   422 
   418 
   423 processAction StatsAction = do
   419 processAction StatsAction = do
   424     rnc <- gets roomsClients
   420     rnc <- gets roomsClients
   425     si <- gets serverInfo
   421     si <- gets serverInfo
   426     (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats
   422     (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
   427     io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
   423     io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
   428     where
   424     where
   429           stats irnc = (length $ allRooms irnc, length $ allClients irnc)
   425           st irnc = (length $ allRooms irnc, length $ allClients irnc)
   430 
   426 
   431 processAction (RestartServer useForce) = do
   427 processAction (RestartServer _) =
   432     return ()
   428     return ()