gameServer/Actions.hs
author sheepluva
Thu, 16 Jan 2014 12:28:41 +0100
changeset 9992 1773ef634b78
parent 9973 7589978c9912
child 10014 56d2f2d5aad8
permissions -rw-r--r--
PhysicsFS 2.0.0 seems to be sufficient; also fix a typo
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
     1
{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
     2
{-# OPTIONS_GHC -fno-warn-orphans #-}
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     3
module Actions where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     4
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     5
import Control.Concurrent
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     6
import qualified Data.Set as Set
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
     7
import qualified Data.Map as Map
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     8
import qualified Data.List as L
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     9
import qualified Control.Exception as Exception
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    10
import System.Log.Logger
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    11
import Control.Monad
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    12
import Data.Time
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    13
import Data.Maybe
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    14
import Control.Monad.Reader
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    15
import Control.Monad.State.Strict
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    16
import qualified Data.ByteString.Char8 as B
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    17
import Control.DeepSeq
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    18
import Data.Unique
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    19
import Control.Arrow
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
    20
import Control.Exception as E
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    21
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
    22
import Network.Socket
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
    23
import System.Random
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
    24
import qualified Data.Traversable as DT
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    25
-----------------------------
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    26
#if defined(OFFICIAL_SERVER)
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
    27
import OfficialServer.GameReplayStore
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    28
#endif
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    29
import CoreTypes
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    30
import Utils
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    31
import ClientIO
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    32
import ServerState
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    33
import Consts
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    34
import ConfigFile
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 6012
diff changeset
    35
import EngineInteraction
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    36
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    37
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    38
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    39
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    40
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    41
othersChans :: StateT ServerState IO [ClientChan]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    42
othersChans = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    43
    cl <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    44
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    45
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    46
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    47
processAction :: Action -> StateT ServerState IO ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    48
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    49
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    50
processAction (AnswerClients chans msg) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    51
    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    52
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    53
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    54
processAction SendServerMessage = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    55
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    56
    protonum <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    57
    si <- liftM serverInfo get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    58
    let message = if protonum < latestReleaseVersion si then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    59
            serverMessageForOldVersions si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    60
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    61
            serverMessage si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    62
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    63
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    64
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    65
processAction SendServerVars = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    66
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    67
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    68
    io $ writeChan chan ("SERVER_VARS" : vars si)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    69
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    70
        vars si = [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    71
            "MOTD_NEW", serverMessage si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    72
            "MOTD_OLD", serverMessageForOldVersions si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    73
            "LATEST_PROTO", showB $ latestReleaseVersion si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    74
            ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    75
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    76
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    77
processAction (ProtocolError msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    78
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    79
    processAction $ AnswerClients [chan] ["ERROR", msg]
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
processAction (Warning msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    83
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    84
    processAction $ AnswerClients [chan] ["WARNING", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    85
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    86
processAction (NoticeMessage n) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    87
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    88
    processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    89
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    90
processAction (ByeClient msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    91
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    92
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    93
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    94
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    95
    clNick <- client's nick
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    96
    loggedIn <- client's isVisible
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    97
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    98
    when (ri /= lobbyId) $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    99
        processAction $ MoveToLobby ("quit: " `B.append` msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   100
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   101
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   102
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   103
    io $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   104
        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   105
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   106
    when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   107
8158
5da1c26d5b10 Fix warning
unc0rr
parents: 8156
diff changeset
   108
    mapM_ processAction
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
   109
        [
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
   110
        AnswerClients [chan] ["BYE", msg]
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   111
        , ModifyClient (\c -> c{nick = "", isVisible = 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
   112
        ]
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
   113
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   114
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   115
    put $! s{removedClients = ci `Set.insert` removedClients s}
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   116
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   117
processAction (DeleteClient ci) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   118
    io $ debugM "Clients"  $ "DeleteClient: " ++ show ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   119
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   120
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   121
    io $ removeClient rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   122
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   123
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   124
    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
   125
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   126
    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
   127
    cls <- allClientsS
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   128
    io $ when (sp && null cls) $ throwIO ShutdownException
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   129
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   130
processAction (ModifyClient f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   131
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   132
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   133
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   134
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   135
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   136
processAction (ModifyClient2 ci f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   137
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   138
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   139
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   140
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   141
processAction (ModifyRoomClients f) = do
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   142
    rnc <- gets roomsClients
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   143
    ri <- clientRoomA
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   144
    roomClIDs <- io $ roomClientsIndicesM rnc ri
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   145
    io $ mapM_ (modifyClient rnc f) roomClIDs
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   146
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   147
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   148
processAction (ModifyRoom f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   149
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   150
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   151
    io $ modifyRoom rnc f ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   152
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   153
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   154
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   155
processAction (ModifyServerInfo f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   156
    modify (\s -> s{serverInfo = f $ serverInfo s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   157
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   158
    io $ writeServerConfig si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   159
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   160
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   161
processAction (MoveToRoom ri) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   162
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   163
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   164
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   165
    io $ do
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   166
        modifyClient rnc (
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   167
            \cl -> cl{teamsInGame = 0
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   168
                , isReady = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   169
                , isMaster = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   170
                , isInGame = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   171
                , isJoinedMidGame = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   172
                , clientClan = Nothing}) ci
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   173
        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   174
        moveClientToRoom rnc ri ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   175
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   176
    chans <- liftM (map sendChan) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   177
    clNick <- client's nick
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   178
    allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   179
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   180
    mapM_ processAction [
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   181
        AnswerClients chans ["JOINED", clNick]
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   182
        , AnswerClients allClientsChans ["CLIENT_FLAGS", "+i", clNick]
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   183
        ]
5184
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 (MoveToLobby msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   187
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   188
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   189
    rnc <- gets roomsClients
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   190
    playersNum <- io $ room'sM rnc playersIn ri
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   191
    specialRoom <- io $ room'sM rnc isSpecial ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   192
    master <- client's isMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   193
--    client <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   194
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   195
    chans <- othersChans
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   196
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   197
    if master then
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   198
        if (playersNum > 1) || specialRoom then
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   199
            mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   200
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   201
            processAction RemoveRoom
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   202
        else
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   203
        mapM_ processAction [RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   204
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   205
    allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   206
    processAction $ AnswerClients allClientsChans ["CLIENT_FLAGS", "-i", clNick]
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   207
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   208
    -- 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
   209
    ready <- client's isReady
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   210
    when (not master || playersNum > 1 || specialRoom) . io $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   211
        modifyRoom rnc (\r -> r{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   212
                playersIn = playersIn r - 1,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   213
                readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   214
                }) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   215
        moveClientToLobby rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   216
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   217
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8245
diff changeset
   218
processAction (ChangeMaster delegateId)= do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   219
    (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
   220
    proto <- client's clientProto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   221
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   222
    rnc <- gets roomsClients
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   223
    specialRoom <- io $ room'sM rnc isSpecial ri
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   224
    newMasterId <- liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc ri
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   225
    newMaster <- io $ client'sM rnc id `DT.mapM` newMasterId
9062
a65492ca1587 Fix room admin rights delegation by server admin when he isn't room admin
unc0rr
parents: 9060
diff changeset
   226
    oldMasterId <- io $ room'sM rnc masterID ri
6733
5abbc345a82f Handle ROOM* commands in rooms list model
unc0rr
parents: 6541
diff changeset
   227
    oldRoomName <- io $ room'sM rnc name ri
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   228
    kicked <- client's isKickedFromServer
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
   229
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   230
    let newRoomName = if ((proto < 42) || kicked) && (not specialRoom) then maybeNick newMaster else oldRoomName
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   231
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   232
    when (isJust oldMasterId) $ do
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   233
        oldMasterNick <- io $ client'sM rnc nick (fromJust oldMasterId)
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   234
        mapM_ processAction [
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   235
            ModifyClient2 (fromJust oldMasterId) (\c -> c{isMaster = False})
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   236
            , AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMasterNick]
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   237
            ]
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   238
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   239
    when (isJust newMasterId) $
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   240
        mapM_ processAction [
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   241
          ModifyClient2 (fromJust newMasterId) (\c -> c{isMaster = True})
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   242
        , AnswerClients [sendChan $ fromJust newMaster] ["ROOM_CONTROL_ACCESS", "1"]
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   243
        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick $ fromJust newMaster]
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   244
        ]
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   245
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   246
    processAction $
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   247
        ModifyRoom (\r -> r{masterID = newMasterId
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   248
                , name = newRoomName
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   249
                , isRestrictedJoins = False
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   250
                , isRestrictedTeams = False
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   251
                , isRegisteredOnly = isSpecial r}
8983
a25e18295959 Restore ready toggle for room admins (issue 432)
unc0rr
parents: 8523
diff changeset
   252
                )
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   253
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   254
    newRoom' <- io $ room'sM rnc id ri
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
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   256
    processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo proto (maybeNick 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
   257
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   258
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   259
processAction (AddRoom roomName roomPassword) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   260
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   261
    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
   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
    n <- client's nick
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   264
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   265
    let rm = newRoom{
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   266
            masterID = Just clId,
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   267
            name = roomName,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   268
            password = roomPassword,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   269
            roomProto = proto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   270
            }
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   271
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   272
    rId <- io $ addRoom rnc rm
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   273
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   274
    processAction $ MoveToRoom rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   275
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
   276
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   277
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   278
    mapM_ processAction [
9702
27006953d901 - Column for script in rooms list
unc0rr
parents: 9662
diff changeset
   279
      AnswerClients chans ("ROOM" : "ADD" : roomInfo proto n rm{playersIn = 1})
5184
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
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   283
processAction RemoveRoom = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   284
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   285
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   286
    ri <- io $ clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   287
    roomName <- io $ room'sM rnc name ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   288
    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
   289
    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
   290
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   291
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   292
    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
   293
            AnswerClients chans ["ROOM", "DEL", roomName],
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   294
            AnswerClients others ["ROOMABANDONED", roomName]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   295
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   296
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   297
    io $ removeRoom rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   298
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   299
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   300
processAction SendUpdateOnThisRoom = do
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   301
    Just clId <- gets clientIndex
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   302
    proto <- client's clientProto
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   303
    rnc <- gets roomsClients
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   304
    ri <- io $ clientRoomM rnc clId
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   305
    rm <- io $ room'sM rnc id ri
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   306
    masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm)
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   307
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9702
diff changeset
   308
    processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo proto (maybeNick masterCl) rm)
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   309
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   310
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
   311
processAction UnreadyRoomClients = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   312
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   313
    roomPlayers <- roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   314
    pr <- client's clientProto
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   315
    mapM_ processAction [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   316
        AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr . map nick . filter (not . isMaster) $ roomPlayers
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   317
        , ModifyRoomClients (\cl -> cl{isReady = isMaster cl, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   318
        , ModifyRoom (\r -> r{readyPlayers = 1})
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   319
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   320
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   321
        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   322
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   323
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
   324
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
   325
    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
   326
    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
   327
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   328
    joinedMidGame <- liftM (filter isJoinedMidGame) $ roomClientsS ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   329
    answerRemovedTeams <- io $
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   330
         room'sM rnc (\r -> let gi = fromJust $ gameInfo r in 
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   331
                        concatMap (\c -> 
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   332
                            (answerFullConfigParams c (mapParams r) (params r))
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   333
                            ++
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   334
                            (map (\t -> AnswerClients [sendChan c] ["REMOVE_TEAM", t]) $ leftTeams gi) 
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   335
                        ) joinedMidGame
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   336
                     ) ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   337
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   338
    mapM_ processAction $ (
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   339
        SaveReplay
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   340
        : 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
   341
            (\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
   342
                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
   343
                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
   344
                }
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
   345
            )
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   346
        : SendUpdateOnThisRoom
8241
b15f165c080c Send "ROUND_FINISHED" to room clients when server thinks so
unc0rr
parents: 8239
diff changeset
   347
        : AnswerClients thisRoomChans ["ROUND_FINISHED"]
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   348
        : answerRemovedTeams
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   349
        )
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   350
        ++ [UnreadyRoomClients]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   351
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   352
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
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
   354
    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
   355
    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
   356
        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
   357
        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
   358
                gameInfo = liftM (\g -> g{
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   359
                    teamsInGameNumber = teamsInGameNumber g - 1
9381
90f9d8046a86 Fix silliness from r3f4c3fc146c2 (was I sleepy?)
unc0rr
parents: 9193
diff changeset
   360
                    , roundMsgs = (if isJust $ lastFilteredTimedMsg g then (:) (fromJust $ lastFilteredTimedMsg g) else id) 
90f9d8046a86 Fix silliness from r3f4c3fc146c2 (was I sleepy?)
unc0rr
parents: 9193
diff changeset
   361
                      $ rmTeamMsg : roundMsgs g
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
                }) $ 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
   363
            })
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
   364
        ]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   365
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
   366
    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
   367
    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
   368
    gi <- io $ room'sM rnc gameInfo ri
8422
ec41194d4444 Okay, let's try not trust even room admin on this
unc0rr
parents: 8403
diff changeset
   369
    when (0 == teamsInGameNumber (fromJust gi)) $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   370
        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
   371
    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
   372
        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   373
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   374
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   375
processAction (RemoveTeam teamName) = do
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   376
    (Just ci) <- gets clientIndex
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   377
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   378
    ri <- clientRoomA
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   379
    inGame <- io $ do
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   380
        r <- room'sM rnc (isJust . gameInfo) ri
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   381
        c <- client'sM rnc isInGame ci
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   382
        return $ r && c
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   383
    chans <- othersChans
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   384
    mapM_ processAction $
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   385
        ModifyRoom (\r -> r{
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   386
            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
   387
            , 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
   388
            })
7947
0cf5277fef1a Better place for SendUpdateOnThisRoom
unc0rr
parents: 7945
diff changeset
   389
        : SendUpdateOnThisRoom
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   390
        : AnswerClients chans ["REMOVE_TEAM", teamName]
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   391
        : [SendTeamRemovalMessage teamName | inGame]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   392
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   393
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   394
processAction RemoveClientTeams = do
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   395
    (Just ci) <- gets clientIndex
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   396
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   397
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   398
    removeTeamActions <- io $ do
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   399
        rId <- clientRoomM rnc ci
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   400
        roomTeams <- room'sM rnc teams rId
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   401
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamownerId t == ci) $ roomTeams
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   402
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   403
    mapM_ processAction removeTeamActions
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   404
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   405
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   406
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   407
processAction CheckRegistered = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   408
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   409
    n <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   410
    h <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   411
    p <- client's clientProto
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   412
    checker <- client's isChecker
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   413
    uid <- client's clUID
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   414
    -- allow multiple checker logins
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   415
    haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS
8476
61d7269f16be Fix server crasher
unc0rr
parents: 8452
diff changeset
   416
    if (not checker) && haveSameNick then
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   417
        if p < 38 then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   418
            processAction $ ByeClient $ loc "Nickname is already in use"
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   419
            else
9032
2345f5f96a29 Clear nickname in case of collision so client could try again. Should help with issue 550 if not fix it.
unc0rr
parents: 8983
diff changeset
   420
            mapM_ processAction [NoticeMessage NickAlreadyInUse, ModifyClient $ \c -> c{nick = B.empty}]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   421
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   422
        do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   423
        db <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   424
        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   425
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   426
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   427
processAction ClearAccountsCache = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   428
    dbq <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   429
    io $ writeChan dbq ClearCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   430
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   431
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   432
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   433
processAction (ProcessAccountInfo info) = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   434
    case info of
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   435
        HasAccount passwd isAdmin isContr -> do
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   436
            b <- isBanned
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   437
            c <- client's isChecker
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   438
            when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin isContr
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   439
        Guest -> do
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   440
            b <- isBanned
8523
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   441
            c <- client's isChecker
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   442
            when (not b) $
8523
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   443
                if c then
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   444
                    checkerLogin "" False False
8523
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   445
                    else
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   446
                    processAction JoinLobby
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   447
        Admin ->
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   448
            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   449
        ReplayName fn -> processAction $ ShowReplay fn
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   450
    where
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   451
    isBanned = do
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   452
        processAction $ CheckBanned False
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   453
        liftM B.null $ client's nick
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   454
    checkerLogin _ False _ = processAction $ ByeClient $ loc "No checker rights"
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   455
    checkerLogin p True _ = do
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   456
        wp <- client's webPassword
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   457
        processAction $
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   458
            if wp == p then ModifyClient $ \c -> c{logonPassed = True} else ByeClient $ loc "Authentication failed"
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   459
    playerLogin p a contr = do
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   460
        chan <- client's sendChan
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   461
        mapM_ processAction [
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   462
            AnswerClients [chan] ["ASKPASSWORD"]
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   463
            , ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr})
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   464
            ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   465
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   466
processAction JoinLobby = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   467
    chan <- client's sendChan
9528
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   468
    rnc <- gets roomsClients
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   469
    clientNick <- client's nick
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   470
    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
   471
    isAdmin <- client's isAdministrator
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   472
    isContr <- client's isContributor
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   473
    loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   474
    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
   475
    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
   476
    let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   477
    let contrNicks = L.map nick . L.filter isContributor $ loggedInClients
9528
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   478
    inRoomNicks <- io $
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   479
        allClientsM rnc
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   480
        >>= filterM (liftM ((/=) lobbyId) . clientRoomM rnc)
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   481
        >>= mapM (client'sM rnc nick)
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   482
    let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin], ["c" | isContr]]
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   483
    mapM_ processAction . concat $ [
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   484
        [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   485
        , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   486
        , [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
   487
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   488
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+c" : contrNicks) | not $ null contrNicks]
9528
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   489
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+i" : inRoomNicks) | not $ null inRoomNicks]
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   490
        , [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS",  B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   491
        , [ModifyClient (\cl -> cl{logonPassed = True, isVisible = True})]
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   492
        , [SendServerMessage]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   493
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   494
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   495
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   496
processAction (KickClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   497
    modify (\s -> s{clientIndex = Just kickId})
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   498
    clHost <- client's host
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   499
    currentTime <- io getCurrentTime
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   500
    mapM_ processAction [
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   501
        AddIP2Bans clHost (loc "60 seconds cooldown after kick") (addUTCTime 60 currentTime)
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   502
        , ModifyClient (\c -> c{isKickedFromServer = True})
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   503
        , ByeClient "Kicked"
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   504
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   505
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   506
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   507
processAction (BanClient seconds reason banId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   508
    modify (\s -> s{clientIndex = Just banId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   509
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   510
    currentTime <- io getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   511
    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   512
    mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   513
        AddIP2Bans clHost msg (addUTCTime seconds currentTime)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   514
        , KickClient banId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   515
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   516
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   517
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   518
processAction (BanIP ip seconds reason) = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   519
    currentTime <- io getCurrentTime
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   520
    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
   521
    processAction $
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   522
        AddIP2Bans ip msg (addUTCTime seconds currentTime)
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   523
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   524
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   525
processAction (BanNick n seconds reason) = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   526
    currentTime <- io getCurrentTime
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   527
    let msg = 
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   528
            if seconds > 60 * 60 * 24 * 365 then
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   529
                B.concat ["Permanent ban (", reason, ")"]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   530
                else
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   531
                B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   532
    processAction $
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   533
        AddNick2Bans n msg (addUTCTime seconds currentTime)
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   534
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   535
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   536
processAction BanList = do
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   537
    time <- io $ getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   538
    ch <- client's sendChan
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   539
    b <- gets (B.intercalate "\n" . concatMap (ban2Str time) . bans . serverInfo)
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   540
    processAction $
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   541
        AnswerClients [ch] ["BANLIST", b]
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   542
    where
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   543
        ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time]
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   544
        ban2Str time (BanByNick b r t) = ["N", b, r, B.pack . show $ t `diffUTCTime` time]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   545
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   546
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   547
processAction (Unban entry) = do
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   548
    processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s})
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   549
    where
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   550
        f (BanByIP bip _ _) = bip == entry
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   551
        f (BanByNick bn _ _) = bn == entry
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   552
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   553
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   554
processAction (KickRoomClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   555
    modify (\s -> s{clientIndex = Just kickId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   556
    ch <- client's sendChan
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   557
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   558
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   559
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   560
processAction (AddClient cl) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   561
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   562
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   563
    newClId <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   564
        ci <- addClient rnc cl
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   565
        _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   566
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   567
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   568
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   569
        return ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   570
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   571
    modify (\s -> s{clientIndex = Just newClId})
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   572
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   573
    jm <- gets joinsMonitor
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   574
    pass <- io $ joinsSentry jm (host cl) (connectTime cl)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   575
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   576
    if pass then
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   577
        mapM_ processAction
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   578
            [
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   579
                CheckBanned True
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   580
                , AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   581
            ]
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   582
        else
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   583
        processAction $ ByeClient $ loc "Reconnected too fast"
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   584
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   585
processAction (AddNick2Bans n reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   586
    processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   587
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   588
processAction (AddIP2Bans ip reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   589
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   590
    rc <- gets removedClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   591
    when (not $ ci `Set.member` rc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   592
        $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   593
8519
98e2dbdda8c0 Workaround desync issue if I correctly understand its roots (barely tested)
unc0rr
parents: 8514
diff changeset
   594
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   595
processAction (CheckBanned byIP) = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   596
    clTime <- client's connectTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   597
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   598
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   599
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   600
    let validBans = filter (checkNotExpired clTime) $ bans si
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   601
    let ban = L.find (checkBan byIP clHost clNick) $ validBans
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   602
    mapM_ processAction $
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   603
        ModifyServerInfo (\s -> s{bans = validBans})
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   604
        : [ByeClient (getBanReason $ fromJust ban) | isJust ban]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   605
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   606
        checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   607
        checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   608
        checkBan True ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   609
        checkBan False _ n (BanByNick bn _ _) = caseInsensitiveCompare bn n
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   610
        checkBan _ _ _ _ = False
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   611
        getBanReason (BanByIP _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   612
        getBanReason (BanByNick _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   613
8519
98e2dbdda8c0 Workaround desync issue if I correctly understand its roots (barely tested)
unc0rr
parents: 8514
diff changeset
   614
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   615
processAction PingAll = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   616
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   617
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   618
    cis <- io $ allClientsM rnc
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   619
    chans <- io $ mapM (client'sM rnc sendChan) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   620
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   621
    processAction $ AnswerClients chans ["PING"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   622
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   623
        kickTimeouted rnc ci = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   624
            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
   625
            when (pq > 0) $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   626
                withStateT (\as -> as{clientIndex = Just ci}) $
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   627
                    processAction (ByeClient $ loc "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
   628
--                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
   629
--                    processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   630
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   631
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   632
processAction StatsAction = do
5211
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   633
    si <- gets serverInfo
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   634
    when (not $ shutdownPending si) $ do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   635
        rnc <- gets roomsClients
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   636
        (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   637
        io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   638
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   639
          st irnc = (length $ allRooms irnc, length $ allClients irnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   640
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   641
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   642
processAction RestartServer = do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   643
    sp <- gets (shutdownPending . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   644
    when (not sp) $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   645
        sock <- gets (fromJust . serverSocket . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   646
        args <- gets (runArgs . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   647
        io $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   648
            noticeM "Core" "Closing listening socket"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   649
            sClose sock
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   650
            noticeM "Core" "Spawning new server"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   651
            _ <- createProcess (proc "./hedgewars-server" args)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   652
            return ()
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   653
        processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   654
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   655
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   656
processAction Stats = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   657
    cls <- allClientsS
8452
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   658
    rms <- allRoomsS
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   659
    let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   660
    let roomsMap = Map.fromListWith (+) . map (\c -> (roomProto c, 1 :: Int)) . filter ((/=) 0 . roomProto) $ rms
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   661
    let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   662
    let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"])
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   663
            . concatMap (\p -> [
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   664
                    "<tr><td>", protoNumber2ver p
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   665
                    , "</td><td>", showB $ Map.findWithDefault 0 p clientsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   666
                    , "</td><td>", showB $ Map.findWithDefault 0 p roomsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   667
                    , "</td></tr>"])
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   668
            . Set.toList $ keys
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   669
    processAction $ Warning versionsStats
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   670
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   671
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   672
processAction (Random chans items) = do
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   673
    let i = if null items then ["heads", "tails"] else items
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   674
    n <- io $ randomRIO (0, length i - 1)
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   675
    processAction $ AnswerClients chans ["CHAT", "[random]", i !! n]
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   676
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   677
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   678
#if defined(OFFICIAL_SERVER)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   679
processAction SaveReplay = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   680
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   681
    rnc <- gets roomsClients
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   682
9437
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
   683
    readyCheckersIds <- io $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   684
        r <- room'sM rnc id ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   685
        saveReplay r
9437
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
   686
        allci <- allClientsM rnc
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
   687
        filterM (client'sM rnc isReadyChecker) allci
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   688
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   689
    when (not $ null readyCheckersIds) $ do
9439
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   690
        oldci <- gets clientIndex
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   691
        withStateT (\s -> s{clientIndex = Just $ head readyCheckersIds})
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   692
            $ processAction CheckRecord
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   693
        modify (\s -> s{clientIndex = oldci})
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   694
    where
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   695
        isReadyChecker cl = isChecker cl && isReady cl
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   696
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   697
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   698
processAction CheckRecord = do
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   699
    p <- client's clientProto
8482
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
   700
    c <- client's sendChan
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   701
    ri <- clientRoomA
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   702
    rnc <- gets roomsClients
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   703
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   704
    blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   705
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   706
    readyCheckersIds <- io $ do
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   707
        allci <- allClientsM rnc
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   708
        filterM (client'sM rnc (isJust . checkInfo)) allci
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   709
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   710
    (cinfo, l) <- io $ loadReplay (fromIntegral p) blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   711
    when (not . null $ l) $
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   712
        mapM_ processAction [
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   713
            AnswerClients [c] ("REPLAY" : l)
9444
30748b1d9ec7 Fix checker ready status mess
unc0rr
parents: 9439
diff changeset
   714
            , ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False}
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   715
            ]
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   716
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   717
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   718
processAction (CheckFailed msg) = do
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   719
    Just (CheckInfo fileName _) <- client's checkInfo
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   720
    io $ moveFailedRecord fileName
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   721
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   722
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   723
processAction (CheckSuccess info) = do
9399
1767c92eff37 Pass achievements info to extdbinterface
unc0rr
parents: 9381
diff changeset
   724
    Just (CheckInfo fileName teams) <- client's checkInfo
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9786
diff changeset
   725
    p <- client's clientProto
9401
2af7bea32e5e - Some fixes to official server build
unc0rr
parents: 9399
diff changeset
   726
    si <- gets serverInfo
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9786
diff changeset
   727
    io $ writeChan (dbQueries si) $ StoreAchievements p (B.pack fileName) (map toPair teams) info
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   728
    io $ moveCheckedRecord fileName
9399
1767c92eff37 Pass achievements info to extdbinterface
unc0rr
parents: 9381
diff changeset
   729
    where
1767c92eff37 Pass achievements info to extdbinterface
unc0rr
parents: 9381
diff changeset
   730
        toPair t = (teamname t, teamowner t)
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   731
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   732
processAction (QueryReplay rname) = do
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   733
    (Just ci) <- gets clientIndex
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   734
    si <- gets serverInfo
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   735
    uid <- client's clUID
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   736
    io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) rname
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   737
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   738
#else
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   739
processAction SaveReplay = return ()
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   740
processAction CheckRecord = return ()
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   741
processAction (CheckFailed _) = return ()
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   742
processAction (CheckSuccess _) = return ()
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   743
processAction (QueryReplay _) = return ()
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   744
#endif
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   745
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   746
processAction (ShowReplay rname) = do
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   747
    c <- client's sendChan
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   748
    cl <- client's id
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   749
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   750
    let fileName = B.concat ["checked/", if B.isPrefixOf "replays/" rname then B.drop 8 rname else rname]
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   751
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   752
    cInfo <- liftIO $ E.handle (\(e :: SomeException) ->
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   753
                    warningM "REPLAYS" (B.unpack $ B.concat ["Problems reading ", fileName, ": ", B.pack $ show e]) >> return Nothing) $ do
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   754
            (t, p1, p2, msgs) <- liftM read $ readFile (B.unpack fileName)
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   755
            return $ Just (t, Map.fromList p1, Map.fromList p2, reverse msgs)
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   756
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   757
    let (teams', params1, params2, roundMsgs') = fromJust cInfo
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   758
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   759
    when (isJust cInfo) $ do
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   760
        mapM_ processAction $ concat [
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   761
            [AnswerClients [c] ["JOINED", nick cl]]
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   762
            , answerFullConfigParams cl params1 params2
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   763
            , answerAllTeams cl teams'
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   764
            , [AnswerClients [c]  ["RUN_GAME"]]
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   765
            , [AnswerClients [c] $ "EM" : roundMsgs']
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   766
            , [AnswerClients [c] ["KICKED"]]
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   767
            ]
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   768
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   769
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   770
processAction Cleanup = do
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   771
    jm <- gets joinsMonitor
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   772
    
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   773
    io $ do
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   774
        t <- getCurrentTime
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   775
        cleanup jm t