gameServer/Actions.hs
author unc0rr
Thu, 23 Feb 2012 18:41:52 +0400
changeset 6733 5abbc345a82f
parent 6541 08ed346ed341
child 6753 e95b1f62d0de
permissions -rw-r--r--
Handle ROOM* commands in rooms list model
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
     1
{-# LANGUAGE CPP, OverloadedStrings #-}
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     2
module Actions where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     3
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     4
import Control.Concurrent
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     5
import qualified Data.Set as Set
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     6
import qualified Data.Sequence as Seq
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     7
import qualified Data.List as L
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     8
import qualified Control.Exception as Exception
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     9
import System.Log.Logger
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    10
import Control.Monad
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    11
import Data.Time
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    12
import Data.Maybe
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    13
import Control.Monad.Reader
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    14
import Control.Monad.State.Strict
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    15
import qualified Data.ByteString.Char8 as B
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    16
import Control.DeepSeq
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    17
import Data.Unique
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    18
import Control.Arrow
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    19
import Control.Exception
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    20
import System.Process
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    21
import Network.Socket
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    22
-----------------------------
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
    23
import OfficialServer.GameReplayStore
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    24
import CoreTypes
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    25
import Utils
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    26
import ClientIO
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    27
import ServerState
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    28
import Consts
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    29
import ConfigFile
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 6012
diff changeset
    30
import EngineInteraction
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    31
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    32
data Action =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    33
    AnswerClients ![ClientChan] ![B.ByteString]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    34
    | SendServerMessage
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    35
    | SendServerVars
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    36
    | MoveToRoom RoomIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    37
    | MoveToLobby B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    38
    | RemoveTeam B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    39
    | RemoveRoom
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    40
    | UnreadyRoomClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    41
    | JoinLobby
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    42
    | ProtocolError B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    43
    | Warning B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    44
    | NoticeMessage Notice
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    45
    | ByeClient B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    46
    | KickClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    47
    | KickRoomClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    48
    | BanClient NominalDiffTime B.ByteString ClientIndex
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
    49
    | BanIP B.ByteString NominalDiffTime B.ByteString
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
    50
    | BanList
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    51
    | ChangeMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    52
    | RemoveClientTeams ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    53
    | ModifyClient (ClientInfo -> ClientInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    54
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    55
    | ModifyRoom (RoomInfo -> RoomInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    56
    | ModifyServerInfo (ServerInfo -> ServerInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    57
    | AddRoom B.ByteString B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    58
    | CheckRegistered
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    59
    | ClearAccountsCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    60
    | ProcessAccountInfo AccountInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    61
    | AddClient ClientInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    62
    | DeleteClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    63
    | PingAll
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    64
    | StatsAction
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    65
    | RestartServer
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    66
    | AddNick2Bans B.ByteString B.ByteString UTCTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    67
    | AddIP2Bans B.ByteString B.ByteString UTCTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    68
    | CheckBanned
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    69
    | SaveReplay
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    70
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    71
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    72
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    73
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    74
instance NFData Action where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    75
    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    76
    rnf a = a `seq` ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    77
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    78
instance NFData B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    79
instance NFData (Chan a)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    80
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    81
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    82
othersChans :: StateT ServerState IO [ClientChan]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    83
othersChans = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    84
    cl <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    85
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    86
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    87
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    88
processAction :: Action -> StateT ServerState IO ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    89
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    90
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    91
processAction (AnswerClients chans msg) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    92
    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    93
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    94
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    95
processAction SendServerMessage = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    96
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    97
    protonum <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    98
    si <- liftM serverInfo get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    99
    let message = if protonum < latestReleaseVersion si then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   100
            serverMessageForOldVersions si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   101
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   102
            serverMessage si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   103
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   104
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   105
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   106
processAction SendServerVars = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   107
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   108
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   109
    io $ writeChan chan ("SERVER_VARS" : vars si)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   110
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   111
        vars si = [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   112
            "MOTD_NEW", serverMessage si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   113
            "MOTD_OLD", serverMessageForOldVersions si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   114
            "LATEST_PROTO", showB $ latestReleaseVersion si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   115
            ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   116
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   117
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   118
processAction (ProtocolError msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   119
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   120
    processAction $ AnswerClients [chan] ["ERROR", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   121
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   122
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   123
processAction (Warning msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   124
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   125
    processAction $ AnswerClients [chan] ["WARNING", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   126
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   127
processAction (NoticeMessage n) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   128
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   129
    processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   130
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   131
processAction (ByeClient msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   132
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   133
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   134
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   135
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   136
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   137
    loggedIn <- client's logonPassed
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   138
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   139
    when (ri /= lobbyId) $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   140
        processAction $ MoveToLobby ("quit: " `B.append` msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   141
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   142
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   143
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   144
    io $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   145
        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   146
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   147
    processAction $ AnswerClients [chan] ["BYE", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   148
    when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   149
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   150
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   151
    put $! s{removedClients = ci `Set.insert` removedClients s}
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   152
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   153
processAction (DeleteClient ci) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   154
    io $ debugM "Clients"  $ "DeleteClient: " ++ show ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   155
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   156
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   157
    io $ removeClient rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   158
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   159
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   160
    put $! s{removedClients = ci `Set.delete` removedClients s}
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   161
    
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   162
    sp <- gets (shutdownPending . serverInfo)
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   163
    cls <- allClientsS
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   164
    io $ when (sp && null cls) $ throwIO ShutdownException
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   165
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   166
processAction (ModifyClient f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   167
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   168
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   169
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   170
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   171
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   172
processAction (ModifyClient2 ci f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   173
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   174
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   175
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   176
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   177
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   178
processAction (ModifyRoom f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   179
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   180
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   181
    io $ modifyRoom rnc f ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   182
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   183
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   185
processAction (ModifyServerInfo f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   186
    modify (\s -> s{serverInfo = f $ serverInfo s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   187
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   188
    io $ writeServerConfig si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   189
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   190
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   191
processAction (MoveToRoom ri) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   192
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   193
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   194
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   195
    io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   196
        modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   197
        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   198
        moveClientToRoom rnc ri ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   199
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   200
    chans <- liftM (map sendChan) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   201
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   202
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   203
    processAction $ AnswerClients chans ["JOINED", clNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   204
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   205
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   206
processAction (MoveToLobby msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   207
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   208
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   209
    rnc <- gets roomsClients
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
   210
    (gameProgress, playersNum) <- io $ room'sM rnc ((isJust . gameInfo) &&& playersIn) ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   211
    ready <- client's isReady
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   212
    master <- client's isMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   213
--    client <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   214
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   215
    chans <- othersChans
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   216
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   217
    if master then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   218
        if gameProgress && playersNum > 1 then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   219
            mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   220
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   221
            processAction RemoveRoom
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   222
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   223
        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   224
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   225
    -- when not removing room
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   226
    when (not master || (gameProgress && playersNum > 1)) . io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   227
        modifyRoom rnc (\r -> r{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   228
                playersIn = playersIn r - 1,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   229
                readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   230
                }) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   231
        moveClientToLobby rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   232
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   233
processAction ChangeMaster = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   234
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   235
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   236
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   237
    newMasterId <- liftM (head . filter (/= ci)) . io $ roomClientsIndicesM rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   238
    newMaster <- io $ client'sM rnc id newMasterId
6733
5abbc345a82f Handle ROOM* commands in rooms list model
unc0rr
parents: 6541
diff changeset
   239
    oldRoomName <- io $ room'sM rnc name ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   240
    let newRoomName = nick newMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   241
    mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   242
        ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   243
        ModifyClient2 newMasterId (\c -> c{isMaster = True}),
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   244
        AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   245
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   246
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   247
    proto <- client's clientProto
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   248
    newRoom <- io $ room'sM rnc id ri
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   249
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
6733
5abbc345a82f Handle ROOM* commands in rooms list model
unc0rr
parents: 6541
diff changeset
   250
    processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo (nick newMaster) newRoom)
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   251
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   252
processAction (AddRoom roomName roomPassword) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   253
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   254
    rnc <- gets roomsClients
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   255
    proto <- client's clientProto
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   256
    n <- client's nick
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   257
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   258
    let rm = newRoom{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   259
            masterID = clId,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   260
            name = roomName,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   261
            password = roomPassword,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   262
            roomProto = proto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   263
            }
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   264
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   265
    rId <- io $ addRoom rnc rm
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   266
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   267
    processAction $ MoveToRoom rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   268
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   269
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   270
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   271
    mapM_ processAction [
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   272
        AnswerClients chans ("ROOM" : "ADD" : roomInfo n rm)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   273
        , ModifyClient (\cl -> cl{isMaster = True})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   274
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   275
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   276
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   277
processAction RemoveRoom = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   278
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   279
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   280
    ri <- io $ clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   281
    roomName <- io $ room'sM rnc name ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   282
    others <- othersChans
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   283
    proto <- client's clientProto
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   284
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   285
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   286
    mapM_ processAction [
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   287
            AnswerClients chans ["ROOM", "DEL", roomName],
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   288
            AnswerClients others ["ROOMABANDONED", roomName]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   289
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   290
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   291
    io $ removeRoom rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   292
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   293
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   294
processAction (UnreadyRoomClients) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   295
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   296
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   297
    roomPlayers <- roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   298
    roomClIDs <- io $ roomClientsIndicesM rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   299
    pr <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   300
    processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   301
    io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   302
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   303
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   304
        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   305
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   306
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   307
processAction (RemoveTeam teamName) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   308
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   309
    ri <- clientRoomA
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
   310
    inGame <- io $ room'sM rnc (isJust . gameInfo) ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   311
    chans <- othersChans
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   312
    if not $ inGame then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   313
            mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   314
                AnswerClients chans ["REMOVE_TEAM", teamName],
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   315
                ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   316
                ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   317
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   318
            mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   319
                AnswerClients chans ["EM", rmTeamMsg],
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   320
                ModifyRoom (\r -> r{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   321
                    teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
   322
                        gameInfo = liftM (\g -> g{
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
   323
                        leftTeams = teamName : leftTeams g,
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
   324
                        roundMsgs = roundMsgs g Seq.|> rmTeamMsg
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5426
diff changeset
   325
                        }) $ gameInfo r
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   326
                    })
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   327
                ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   328
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   329
        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   330
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   331
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   332
processAction (RemoveClientTeams clId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   333
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   334
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   335
    removeTeamActions <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   336
        clNick <- client'sM rnc nick clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   337
        rId <- clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   338
        roomTeams <- room'sM rnc teams rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   339
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   340
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   341
    mapM_ processAction removeTeamActions
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   342
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   343
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   344
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   345
processAction CheckRegistered = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   346
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   347
    n <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   348
    h <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   349
    p <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   350
    uid <- client's clUID
6191
190a8e5d9956 Case-insensitive comparison of nicks
unc0rr
parents: 6068
diff changeset
   351
    haveSameNick <- liftM (not . null . tail . filter (\c -> caseInsensitiveCompare (nick c) n)) allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   352
    if haveSameNick then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   353
        if p < 38 then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   354
            mapM_ processAction [ByeClient "Nickname is already in use", removeNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   355
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   356
            mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   357
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   358
        do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   359
        db <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   360
        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   361
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   362
   where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   363
       removeNick = ModifyClient (\c -> c{nick = ""})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   364
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   365
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   366
processAction ClearAccountsCache = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   367
    dbq <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   368
    io $ writeChan dbq ClearCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   369
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   370
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   371
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   372
processAction (ProcessAccountInfo info) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   373
    case info of
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   374
        HasAccount passwd isAdmin -> do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   375
            chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   376
            mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   377
        Guest ->
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   378
            processAction JoinLobby
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   379
        Admin -> do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   380
            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   381
            chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   382
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   383
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   384
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   385
processAction JoinLobby = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   386
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   387
    clientNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   388
    (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   389
    mapM_ processAction $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   390
        AnswerClients clientsChans ["LOBBY:JOINED", clientNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   391
        : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   392
        : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   393
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   394
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   395
processAction (KickClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   396
    modify (\s -> s{clientIndex = Just kickId})
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   397
    clHost <- client's host
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   398
    currentTime <- io getCurrentTime
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   399
    mapM_ processAction [
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   400
        AddIP2Bans clHost "60 seconds cooldown after kick" (addUTCTime 60 currentTime),
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   401
        ByeClient "Kicked"
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   402
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   403
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   404
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   405
processAction (BanClient seconds reason banId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   406
    modify (\s -> s{clientIndex = Just banId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   407
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   408
    currentTime <- io getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   409
    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   410
    mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   411
        AddIP2Bans clHost msg (addUTCTime seconds currentTime)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   412
        , KickClient banId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   413
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   414
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   415
processAction (BanIP ip seconds reason) = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   416
    currentTime <- io getCurrentTime
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   417
    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   418
    processAction $
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   419
        AddIP2Bans ip msg (addUTCTime seconds currentTime)
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   420
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   421
processAction BanList = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   422
    ch <- client's sendChan
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   423
    bans <- gets (bans . serverInfo)
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   424
    processAction $
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   425
        AnswerClients [ch] ["BANLIST", B.pack $ show bans]
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   426
    
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   427
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   428
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   429
processAction (KickRoomClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   430
    modify (\s -> s{clientIndex = Just kickId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   431
    ch <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   432
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   433
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   434
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   435
processAction (AddClient cl) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   436
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   437
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   438
    newClId <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   439
        ci <- addClient rnc cl
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   440
        _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   441
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   442
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   443
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   444
        return ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   445
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   446
    modify (\s -> s{clientIndex = Just newClId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   447
    mapM_ processAction
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   448
        [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   449
            AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   450
            , CheckBanned
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   451
            , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   452
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   453
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   454
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   455
processAction (AddNick2Bans n reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   456
    processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   457
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   458
processAction (AddIP2Bans ip reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   459
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   460
    rc <- gets removedClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   461
    when (not $ ci `Set.member` rc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   462
        $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   463
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   464
processAction CheckBanned = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   465
    clTime <- client's connectTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   466
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   467
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   468
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   469
    let validBans = filter (checkNotExpired clTime) $ bans si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   470
    let ban = L.find (checkBan clHost clNick) $ validBans
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   471
    mapM_ processAction $
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   472
        ModifyServerInfo (\s -> s{bans = validBans})
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   473
        : [ByeClient (getBanReason $ fromJust ban) | isJust ban]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   474
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   475
        checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   476
        checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   477
        checkBan ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   478
        checkBan _ n (BanByNick bn _ _) = bn == n
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   479
        getBanReason (BanByIP _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   480
        getBanReason (BanByNick _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   481
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   482
processAction PingAll = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   483
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   484
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   485
    cis <- io $ allClientsM rnc
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   486
    chans <- io $ mapM (client'sM rnc sendChan) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   487
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   488
    processAction $ AnswerClients chans ["PING"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   489
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   490
        kickTimeouted rnc ci = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   491
            pq <- io $ client'sM rnc pingsQueue ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   492
            when (pq > 0) $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   493
                withStateT (\as -> as{clientIndex = Just ci}) $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   494
                    processAction (ByeClient "Ping timeout")
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   495
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   496
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   497
processAction StatsAction = do
5211
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   498
    si <- gets serverInfo
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   499
    when (not $ shutdownPending si) $ do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   500
        rnc <- gets roomsClients
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   501
        (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   502
        io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   503
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   504
          st irnc = (length $ allRooms irnc, length $ allClients irnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   505
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   506
processAction RestartServer = do 
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   507
    sp <- gets (shutdownPending . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   508
    when (not sp) $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   509
        sock <- gets (fromJust . serverSocket . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   510
        args <- gets (runArgs . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   511
        io $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   512
            noticeM "Core" "Closing listening socket"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   513
            sClose sock
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   514
            noticeM "Core" "Spawning new server"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   515
            _ <- createProcess (proc "./hedgewars-server" args)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   516
            return ()
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   517
        processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   518
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   519
#if defined(OFFICIAL_SERVER)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   520
processAction SaveReplay = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   521
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   522
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   523
    io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   524
        r <- room'sM rnc id ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   525
        saveReplay r
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   526
#else
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   527
processAction SaveReplay = return ()
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   528
#endif