gameServer/Actions.hs
author unc0rr
Sat, 13 Oct 2012 00:07:46 +0400
changeset 7748 f160fbc139b1
parent 7735 4c7e282b5732
child 7757 c20e6c80e249
permissions -rw-r--r--
UNBAN implementation
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
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
    39
    | SendTeamRemovalMessage B.ByteString
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    40
    | RemoveRoom
6758
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
    41
    | FinishGame
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    42
    | UnreadyRoomClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    43
    | JoinLobby
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    44
    | ProtocolError B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    45
    | Warning B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    46
    | NoticeMessage Notice
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    47
    | ByeClient B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    48
    | KickClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    49
    | KickRoomClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    50
    | BanClient NominalDiffTime B.ByteString ClientIndex
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
    51
    | BanIP B.ByteString NominalDiffTime B.ByteString
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
    52
    | BanList
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
    53
    | Unban B.ByteString
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    54
    | ChangeMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    55
    | RemoveClientTeams ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    56
    | ModifyClient (ClientInfo -> ClientInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    57
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    58
    | ModifyRoom (RoomInfo -> RoomInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    59
    | ModifyServerInfo (ServerInfo -> ServerInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    60
    | AddRoom B.ByteString B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    61
    | CheckRegistered
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    62
    | ClearAccountsCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    63
    | ProcessAccountInfo AccountInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    64
    | AddClient ClientInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    65
    | DeleteClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    66
    | PingAll
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    67
    | StatsAction
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    68
    | RestartServer
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    69
    | AddNick2Bans B.ByteString B.ByteString UTCTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    70
    | AddIP2Bans B.ByteString B.ByteString UTCTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    71
    | CheckBanned
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    72
    | SaveReplay
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    73
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    74
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    75
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    76
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    77
instance NFData Action where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    78
    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    79
    rnf a = a `seq` ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    80
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    81
instance NFData B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    82
instance NFData (Chan a)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    83
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    84
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    85
othersChans :: StateT ServerState IO [ClientChan]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    86
othersChans = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    87
    cl <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    88
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    89
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    90
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    91
processAction :: Action -> StateT ServerState IO ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    92
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    93
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    94
processAction (AnswerClients chans msg) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    95
    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    96
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    97
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    98
processAction SendServerMessage = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    99
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   100
    protonum <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   101
    si <- liftM serverInfo get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   102
    let message = if protonum < latestReleaseVersion si then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   103
            serverMessageForOldVersions si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   104
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   105
            serverMessage si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   106
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   107
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   108
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   109
processAction SendServerVars = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   110
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   111
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   112
    io $ writeChan chan ("SERVER_VARS" : vars si)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   113
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   114
        vars si = [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   115
            "MOTD_NEW", serverMessage si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   116
            "MOTD_OLD", serverMessageForOldVersions si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   117
            "LATEST_PROTO", showB $ latestReleaseVersion si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   118
            ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   119
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   120
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   121
processAction (ProtocolError msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   122
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   123
    processAction $ AnswerClients [chan] ["ERROR", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   124
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   125
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   126
processAction (Warning msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   127
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   128
    processAction $ AnswerClients [chan] ["WARNING", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   129
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   130
processAction (NoticeMessage n) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   131
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   132
    processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   133
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   134
processAction (ByeClient msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   135
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   136
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   137
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   138
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   139
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   140
    loggedIn <- client's logonPassed
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   141
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   142
    when (ri /= lobbyId) $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   143
        processAction $ MoveToLobby ("quit: " `B.append` msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   144
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   145
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   146
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   147
    io $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   148
        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   149
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   150
    when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   151
7465
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   152
    mapM processAction
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   153
        [
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   154
        AnswerClients [chan] ["BYE", msg]
7735
4c7e282b5732 Reset nickname so it may be reused while old connection is still hanging
unc0rr
parents: 7710
diff changeset
   155
        , ModifyClient (\c -> c{nick = "", logonPassed = False}) -- this will effectively hide client from others while he isn't deleted from list
7465
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   156
        ]
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   157
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   158
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   159
    put $! s{removedClients = ci `Set.insert` removedClients s}
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   160
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   161
processAction (DeleteClient ci) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   162
    io $ debugM "Clients"  $ "DeleteClient: " ++ show ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   163
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   164
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   165
    io $ removeClient rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   166
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   167
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   168
    put $! s{removedClients = ci `Set.delete` removedClients s}
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   169
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   170
    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
   171
    cls <- allClientsS
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   172
    io $ when (sp && null cls) $ throwIO ShutdownException
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   173
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   174
processAction (ModifyClient f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   175
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   176
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   177
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   178
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   179
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   180
processAction (ModifyClient2 ci f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   181
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   182
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   183
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   185
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   186
processAction (ModifyRoom f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   187
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   188
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   189
    io $ modifyRoom rnc f ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   190
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   191
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   192
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   193
processAction (ModifyServerInfo f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   194
    modify (\s -> s{serverInfo = f $ serverInfo s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   195
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   196
    io $ writeServerConfig si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   197
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   198
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   199
processAction (MoveToRoom ri) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   200
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   201
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   202
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   203
    io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   204
        modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   205
        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   206
        moveClientToRoom rnc ri ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   207
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   208
    chans <- liftM (map sendChan) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   209
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   210
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   211
    processAction $ AnswerClients chans ["JOINED", clNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   212
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   213
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   214
processAction (MoveToLobby msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   215
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   216
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   217
    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
   218
    (gameProgress, playersNum) <- io $ room'sM rnc ((isJust . gameInfo) &&& playersIn) ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   219
    master <- client's isMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   220
--    client <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   221
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   222
    chans <- othersChans
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   223
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   224
    if master then
7521
093ea41051c5 Keep room till last player quits
unc0rr
parents: 7498
diff changeset
   225
        if playersNum > 1 then
7351
34efdd1f230f - Check ready status only after deleting player's teams (should fix the bug when you're unable to start game)
unc0rr
parents: 7321
diff changeset
   226
            mapM_ processAction [ChangeMaster, NoticeMessage AdminLeft, RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   227
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   228
            processAction RemoveRoom
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   229
        else
7351
34efdd1f230f - Check ready status only after deleting player's teams (should fix the bug when you're unable to start game)
unc0rr
parents: 7321
diff changeset
   230
        mapM_ processAction [RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   231
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   232
    -- when not removing room
7351
34efdd1f230f - Check ready status only after deleting player's teams (should fix the bug when you're unable to start game)
unc0rr
parents: 7321
diff changeset
   233
    ready <- client's isReady
7521
093ea41051c5 Keep room till last player quits
unc0rr
parents: 7498
diff changeset
   234
    when (not master || playersNum > 1) . io $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   235
        modifyRoom rnc (\r -> r{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   236
                playersIn = playersIn r - 1,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   237
                readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   238
                }) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   239
        moveClientToLobby rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   240
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   241
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   242
processAction ChangeMaster = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   243
    (Just ci) <- gets clientIndex
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   244
    proto <- client's clientProto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   245
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   246
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   247
    newMasterId <- liftM (head . filter (/= ci)) . io $ roomClientsIndicesM rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   248
    newMaster <- io $ client'sM rnc id newMasterId
6733
5abbc345a82f Handle ROOM* commands in rooms list model
unc0rr
parents: 6541
diff changeset
   249
    oldRoomName <- io $ room'sM rnc name ri
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   250
    oldMaster <- client's nick
7668
4cb423f42105 Show who is the room admin on join (no tested, also I don't like how it is done via server warnings, but it seems there's no other solution compatible with .17)
unc0rr
parents: 7664
diff changeset
   251
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   252
    let newRoomName = if proto < 42 then nick newMaster else oldRoomName
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   253
    mapM_ processAction [
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   254
        ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName, isRestrictedJoins = False, isRestrictedTeams = False})
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   255
        , ModifyClient2 newMasterId (\c -> c{isMaster = True})
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   256
        , AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   257
        , AnswerClients thisRoomChans ["WARNING", "New room admin is " `B.append` nick newMaster]
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   258
        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMaster]
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   259
        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick newMaster]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   260
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   261
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
   262
    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
   263
    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
   264
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   265
    processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo newRoomName 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
   266
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   267
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   268
processAction (AddRoom roomName roomPassword) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   269
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   270
    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
   271
    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
   272
    n <- client's nick
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   273
    chan <- client's sendChan
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   274
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   275
    let rm = newRoom{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   276
            masterID = clId,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   277
            name = roomName,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   278
            password = roomPassword,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   279
            roomProto = proto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   280
            }
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   281
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   282
    rId <- io $ addRoom rnc rm
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   283
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   284
    processAction $ MoveToRoom rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   285
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
   286
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   287
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   288
    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
   289
        AnswerClients chans ("ROOM" : "ADD" : roomInfo n rm)
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   290
        , AnswerClients [chan] ["CLIENT_FLAGS", "+h", n]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   291
        , ModifyClient (\cl -> cl{isMaster = True})
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
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   295
processAction RemoveRoom = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   296
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   297
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   298
    ri <- io $ clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   299
    roomName <- io $ room'sM rnc name ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   300
    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
   301
    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
   302
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   303
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   304
    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
   305
            AnswerClients chans ["ROOM", "DEL", roomName],
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   306
            AnswerClients others ["ROOMABANDONED", roomName]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   307
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   308
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   309
    io $ removeRoom rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   310
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   311
6758
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   312
processAction UnreadyRoomClients = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   313
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   314
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   315
    roomPlayers <- roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   316
    roomClIDs <- io $ roomClientsIndicesM rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   317
    pr <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   318
    processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   319
    io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   320
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   321
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   322
        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   323
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   324
6758
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   325
processAction FinishGame = do
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   326
    rnc <- gets roomsClients
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   327
    ri <- clientRoomA
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   328
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   329
    clNick <- client's nick
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   330
    answerRemovedTeams <- io $
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   331
         room'sM rnc (map (\t -> AnswerClients thisRoomChans ["REMOVE_TEAM", t]) . leftTeams . fromJust . gameInfo) ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   332
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   333
    mapM_ processAction $
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   334
        SaveReplay
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   335
        : ModifyRoom
6758
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   336
            (\r -> r{
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   337
                gameInfo = Nothing,
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   338
                readyPlayers = 0
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   339
                }
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   340
            )
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   341
        : UnreadyRoomClients
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   342
        : answerRemovedTeams
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   343
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   344
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   345
processAction (SendTeamRemovalMessage teamName) = do
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   346
    chans <- othersChans
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   347
    mapM_ processAction [
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   348
        AnswerClients chans ["EM", rmTeamMsg],
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   349
        ModifyRoom (\r -> r{
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   350
                gameInfo = liftM (\g -> g{
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   351
                    teamsInGameNumber = teamsInGameNumber g - 1
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   352
                    , roundMsgs = roundMsgs g Seq.|> rmTeamMsg
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   353
                }) $ gameInfo r
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   354
            })
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   355
        ]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   356
6758
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   357
    rnc <- gets roomsClients
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   358
    ri <- clientRoomA
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   359
    gi <- io $ room'sM rnc gameInfo ri
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   360
    when (isJust gi && 0 == teamsInGameNumber (fromJust gi)) $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   361
        processAction FinishGame
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   362
    where
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   363
        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   364
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   365
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   366
processAction (RemoveTeam teamName) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   367
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   368
    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
   369
    inGame <- io $ room'sM rnc (isJust . gameInfo) ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   370
    chans <- othersChans
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   371
    mapM_ processAction $
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   372
        ModifyRoom (\r -> r{
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   373
            teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   374
            , gameInfo = liftM (\g -> g{leftTeams = teamName : leftTeams g}) $ gameInfo r
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   375
            })
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   376
        : AnswerClients chans ["REMOVE_TEAM", teamName]
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   377
        : [SendTeamRemovalMessage teamName | inGame]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   378
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   379
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   380
processAction (RemoveClientTeams clId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   381
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   382
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   383
    removeTeamActions <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   384
        clNick <- client'sM rnc nick clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   385
        rId <- clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   386
        roomTeams <- room'sM rnc teams rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   387
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   388
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   389
    mapM_ processAction removeTeamActions
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   390
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   391
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   392
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   393
processAction CheckRegistered = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   394
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   395
    n <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   396
    h <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   397
    p <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   398
    uid <- client's clUID
6191
190a8e5d9956 Case-insensitive comparison of nicks
unc0rr
parents: 6068
diff changeset
   399
    haveSameNick <- liftM (not . null . tail . filter (\c -> caseInsensitiveCompare (nick c) n)) allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   400
    if haveSameNick then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   401
        if p < 38 then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   402
            mapM_ processAction [ByeClient "Nickname is already in use", removeNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   403
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   404
            mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   405
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   406
        do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   407
        db <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   408
        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   409
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   410
   where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   411
       removeNick = ModifyClient (\c -> c{nick = ""})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   412
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   413
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   414
processAction ClearAccountsCache = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   415
    dbq <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   416
    io $ writeChan dbq ClearCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   417
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   418
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   419
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   420
processAction (ProcessAccountInfo info) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   421
    case info of
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   422
        HasAccount passwd isAdmin -> do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   423
            chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   424
            mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   425
        Guest ->
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   426
            processAction JoinLobby
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   427
        Admin -> do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   428
            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   429
            chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   430
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   431
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   432
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   433
processAction JoinLobby = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   434
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   435
    clientNick <- client's nick
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   436
    isAuthenticated <- liftM (not . B.null) $ client's webPassword
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   437
    isAdmin <- client's isAdministrator
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   438
    loggedInClients <- liftM (Prelude.filter logonPassed) $! allClientsS
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   439
    let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   440
    let authenticatedNicks = L.map nick . L.filter (not . B.null . webPassword) $ loggedInClients
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   441
    let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   442
    let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin]]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   443
    mapM_ processAction . concat $ [
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   444
        [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   445
        , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   446
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   447
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   448
        , [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS",  B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   449
        , [ModifyClient (\cl -> cl{logonPassed = True})]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   450
        , [SendServerMessage]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   451
        ]
5184
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
processAction (KickClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   455
    modify (\s -> s{clientIndex = Just kickId})
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   456
    clHost <- client's host
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   457
    currentTime <- io getCurrentTime
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   458
    mapM_ processAction [
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   459
        AddIP2Bans clHost "60 seconds cooldown after kick" (addUTCTime 60 currentTime),
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   460
        ByeClient "Kicked"
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   461
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   462
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   463
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   464
processAction (BanClient seconds reason banId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   465
    modify (\s -> s{clientIndex = Just banId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   466
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   467
    currentTime <- io getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   468
    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   469
    mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   470
        AddIP2Bans clHost msg (addUTCTime seconds currentTime)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   471
        , KickClient banId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   472
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   473
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   474
processAction (BanIP ip seconds reason) = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   475
    currentTime <- io getCurrentTime
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   476
    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
   477
    processAction $
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   478
        AddIP2Bans ip msg (addUTCTime seconds currentTime)
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   479
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   480
processAction BanList = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   481
    ch <- client's sendChan
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7521
diff changeset
   482
    bans <- gets (B.pack . unlines . map show . bans . serverInfo)
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   483
    processAction $
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7521
diff changeset
   484
        AnswerClients [ch] ["BANLIST", bans]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   485
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   486
processAction (Unban entry) = do
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   487
    processAction $ ModifyServerInfo (\s -> s{bans = filter f $ bans s})
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   488
    where
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   489
        f (BanByIP bip _ _) = bip == entry
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   490
        f (BanByNick bn _ _) = bn == entry
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   491
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   492
processAction (KickRoomClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   493
    modify (\s -> s{clientIndex = Just kickId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   494
    ch <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   495
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   496
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   497
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   498
processAction (AddClient cl) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   499
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   500
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   501
    newClId <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   502
        ci <- addClient rnc cl
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   503
        _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   504
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   505
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   506
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   507
        return ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   508
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   509
    modify (\s -> s{clientIndex = Just newClId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   510
    mapM_ processAction
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   511
        [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   512
            AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   513
            , CheckBanned
6809
unc0rr
parents: 6805
diff changeset
   514
            , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   515
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   516
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   517
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   518
processAction (AddNick2Bans n reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   519
    processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   520
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   521
processAction (AddIP2Bans ip reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   522
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   523
    rc <- gets removedClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   524
    when (not $ ci `Set.member` rc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   525
        $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   526
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   527
processAction CheckBanned = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   528
    clTime <- client's connectTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   529
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   530
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   531
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   532
    let validBans = filter (checkNotExpired clTime) $ bans si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   533
    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
   534
    mapM_ processAction $
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   535
        ModifyServerInfo (\s -> s{bans = validBans})
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   536
        : [ByeClient (getBanReason $ fromJust ban) | isJust ban]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   537
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   538
        checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   539
        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
   540
        checkBan ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   541
        checkBan _ n (BanByNick bn _ _) = bn == n
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   542
        getBanReason (BanByIP _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   543
        getBanReason (BanByNick _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   544
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   545
processAction PingAll = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   546
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   547
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   548
    cis <- io $ allClientsM rnc
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   549
    chans <- io $ mapM (client'sM rnc sendChan) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   550
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   551
    processAction $ AnswerClients chans ["PING"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   552
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   553
        kickTimeouted rnc ci = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   554
            pq <- io $ client'sM rnc pingsQueue ci
7465
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   555
            when (pq > 0) $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   556
                withStateT (\as -> as{clientIndex = Just ci}) $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   557
                    processAction (ByeClient "Ping timeout")
7600
31a177d2856c Disable workaround, as it still makes server crash and hung clients are hidden from players anyway
unc0rr
parents: 7537
diff changeset
   558
--                when (pq > 1) $
31a177d2856c Disable workaround, as it still makes server crash and hung clients are hidden from players anyway
unc0rr
parents: 7537
diff changeset
   559
--                    processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   560
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   561
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   562
processAction StatsAction = do
5211
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   563
    si <- gets serverInfo
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   564
    when (not $ shutdownPending si) $ do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   565
        rnc <- gets roomsClients
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   566
        (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   567
        io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   568
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   569
          st irnc = (length $ allRooms irnc, length $ allClients irnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   570
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   571
processAction RestartServer = do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   572
    sp <- gets (shutdownPending . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   573
    when (not sp) $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   574
        sock <- gets (fromJust . serverSocket . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   575
        args <- gets (runArgs . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   576
        io $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   577
            noticeM "Core" "Closing listening socket"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   578
            sClose sock
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   579
            noticeM "Core" "Spawning new server"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   580
            _ <- createProcess (proc "./hedgewars-server" args)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   581
            return ()
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   582
        processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   583
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   584
#if defined(OFFICIAL_SERVER)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   585
processAction SaveReplay = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   586
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   587
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   588
    io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   589
        r <- room'sM rnc id ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   590
        saveReplay r
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   591
#else
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   592
processAction SaveReplay = return ()
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   593
#endif