gameServer/Actions.hs
author alfadur
Thu, 28 Mar 2024 00:17:01 +0300
changeset 16003 abea7f16a03b
parent 15878 fc3cb23fd26f
permissions -rw-r--r--
fix room joining
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10944
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10259
diff changeset
    18
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
    19
{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    20
{-# OPTIONS_GHC -fno-warn-orphans #-}
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    21
module Actions where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    22
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    23
import Control.Concurrent
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    24
import qualified Data.Set as Set
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
    25
import qualified Data.Map as Map
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    26
import qualified Data.List as L
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    27
import Data.Word
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    28
import qualified Control.Exception as Exception
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    29
import System.Log.Logger
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    30
import Control.Monad
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    31
import Data.Time
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    32
import Data.Maybe
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    33
import Control.Monad.Reader
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    34
import Control.Monad.State.Strict
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    35
import qualified Data.ByteString.Char8 as B
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    36
import Control.DeepSeq
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    37
import Data.Unique
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    38
import Control.Arrow
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
    39
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
    40
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
    41
import Network.Socket
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
    42
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
    43
import qualified Data.Traversable as DT
12864
73ebc894a725 dependency fixes
astro
parents: 12761
diff changeset
    44
import Text.Regex.TDFA
11854
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
    45
import qualified Text.Regex.TDFA as TDFA
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
    46
import qualified Text.Regex.TDFA.ByteString as TDFAB
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    47
-----------------------------
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    48
#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
    49
import OfficialServer.GameReplayStore
14287
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
    50
import qualified Data.Yaml as YAML
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    51
#endif
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    52
import CoreTypes
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    53
import Utils
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    54
import ClientIO
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    55
import ServerState
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    56
import Consts
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    57
import ConfigFile
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 6012
diff changeset
    58
import EngineInteraction
10092
a92a4ba39a79 Fix build
unc0rr
parents: 10090
diff changeset
    59
import FloodDetection
10212
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
    60
import HWProtoCore
10216
6928a323097f Fix build
unc0rr
parents: 10215
diff changeset
    61
import Votes
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    62
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    63
othersChans :: StateT ServerState IO [ClientChan]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    64
othersChans = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    65
    cl <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    66
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    67
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    68
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    69
othersChansProto :: StateT ServerState IO [(ClientChan, Word16)]
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    70
othersChansProto = do
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    71
    cl <- client's id
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    72
    ri <- clientRoomA
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    73
    map (\ci -> (sendChan ci, clientProto ci)) . filter (/= cl) <$> roomClientsS ri
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    74
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    75
processAction :: Action -> StateT ServerState IO ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    76
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    77
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    78
processAction (AnswerClients chans msg) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    79
    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    80
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    81
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    82
processAction (AnswerClientsByProto chansProto msgFunc) =
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    83
    io $ mapM_ (\(chan, proto) -> writeChan chan (msgFunc proto)) chansProto
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    84
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
    85
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    86
processAction SendServerMessage = 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
    protonum <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    89
    si <- liftM serverInfo get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    90
    let message = if protonum < latestReleaseVersion si then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    91
            serverMessageForOldVersions si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    92
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    93
            serverMessage si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    94
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    95
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    96
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    97
processAction SendServerVars = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    98
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    99
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   100
    io $ writeChan chan ("SERVER_VARS" : vars si)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   101
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   102
        vars si = [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   103
            "MOTD_NEW", serverMessage si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   104
            "MOTD_OLD", serverMessageForOldVersions si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   105
            "LATEST_PROTO", showB $ latestReleaseVersion si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   106
            ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   107
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   108
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   109
processAction (ProtocolError msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   110
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   111
    processAction $ AnswerClients [chan] ["ERROR", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   112
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   113
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   114
processAction (Warning msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   115
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   116
    processAction $ AnswerClients [chan] ["WARNING", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   117
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   118
processAction (NoticeMessage n) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   119
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   120
    processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   121
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   122
processAction (ByeClient msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   123
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   124
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   125
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   126
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   127
    clNick <- client's nick
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   128
    loggedIn <- client's isVisible
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   129
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   130
    when (ri /= lobbyId) $ do
13673
1aa5e884326a Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents: 13657
diff changeset
   131
        processAction $ (MoveToLobby msg)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   132
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   133
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   134
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   135
    io $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   136
        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   137
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   138
    when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   139
8158
5da1c26d5b10 Fix warning
unc0rr
parents: 8156
diff changeset
   140
    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
   141
        [
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
   142
        AnswerClients [chan] ["BYE", msg]
15788
acf70c44065b Use the singular 'they' in code comments, where it makes sense
Wuzzy <Wuzzy2@mail.ru>
parents: 15699
diff changeset
   143
        , ModifyClient (\c -> c{nick = "", isVisible = False}) -- this will effectively hide client from others while it 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
   144
        ]
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
   145
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   146
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   147
    put $! s{removedClients = ci `Set.insert` removedClients s}
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   148
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   149
processAction (DeleteClient ci) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   150
    io $ debugM "Clients"  $ "DeleteClient: " ++ show ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   151
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   152
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   153
    io $ removeClient rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   154
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   155
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   156
    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
   157
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   158
    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
   159
    cls <- allClientsS
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   160
    io $ when (sp && null cls) $ throwIO ShutdownException
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   161
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   162
processAction (ModifyClient f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   163
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   164
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   165
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   166
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   167
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   168
processAction (ModifyClient2 ci f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   169
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   170
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   171
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   172
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   173
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
   174
    rnc <- gets roomsClients
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   175
    ri <- clientRoomA
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   176
    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
   177
    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
   178
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   179
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   180
processAction (ModifyRoom f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   181
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   182
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   183
    io $ modifyRoom rnc f ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   184
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   185
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   186
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   187
processAction (ModifyServerInfo f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   188
    modify (\s -> s{serverInfo = f $ serverInfo s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   189
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   190
    io $ writeServerConfig si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   191
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   192
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   193
processAction (MoveToRoom ri) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   194
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   195
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   196
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   197
    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
   198
        modifyClient rnc (
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   199
            \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
   200
                , isReady = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   201
                , isMaster = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   202
                , isInGame = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   203
                , isJoinedMidGame = False
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   204
                , clientClan = Nothing}) ci
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   205
        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   206
        moveClientToRoom rnc ri ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   207
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   208
    chans <- liftM (map sendChan) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   209
    clNick <- client's nick
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   210
    allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   211
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   212
    mapM_ processAction [
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   213
        AnswerClients chans ["JOINED", clNick]
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   214
        , AnswerClients allClientsChans ["CLIENT_FLAGS", "+i", clNick]
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10092
diff changeset
   215
        , RegisterEvent RoomJoin
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   216
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   217
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   218
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   219
processAction (MoveToLobby msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   220
    (Just ci) <- gets clientIndex
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
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   223
    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
   224
    specialRoom <- io $ room'sM rnc isSpecial ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   225
    master <- client's isMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   226
--    client <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   227
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   228
    chans <- othersChans
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   229
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   230
    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
   231
        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
   232
            mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   233
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   234
            processAction RemoveRoom
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   235
        else
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   236
        mapM_ processAction [RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   237
9193
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   238
    allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   239
    processAction $ AnswerClients allClientsChans ["CLIENT_FLAGS", "-i", clNick]
1394137589e4 'i' flag for in-room status
unc0rr
parents: 9109
diff changeset
   240
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   241
    -- 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
   242
    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
   243
    when (not master || playersNum > 1 || specialRoom) . io $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   244
        modifyRoom rnc (\r -> r{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   245
                playersIn = playersIn r - 1,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   246
                readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   247
                }) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   248
        moveClientToLobby rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   249
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   250
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8245
diff changeset
   251
processAction (ChangeMaster delegateId)= do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   252
    (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
   253
    proto <- client's clientProto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   254
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   255
    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
   256
    specialRoom <- io $ room'sM rnc isSpecial ri
10056
cb9e07753802 Don't delegate special room to another player when owner quits
unc0rr
parents: 10017
diff changeset
   257
    newMasterId <- if specialRoom then 
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10057
diff changeset
   258
        return delegateId
10056
cb9e07753802 Don't delegate special room to another player when owner quits
unc0rr
parents: 10017
diff changeset
   259
        else
cb9e07753802 Don't delegate special room to another player when owner quits
unc0rr
parents: 10017
diff changeset
   260
        liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc 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
   261
    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
   262
    oldMasterId <- io $ room'sM rnc masterID ri
6733
5abbc345a82f Handle ROOM* commands in rooms list model
unc0rr
parents: 6541
diff changeset
   263
    oldRoomName <- io $ room'sM rnc name ri
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   264
    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
   265
    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
   266
    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
   267
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
   268
    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
   269
        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
   270
        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
   271
            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
   272
            , 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
   273
            ]
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
   274
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
   275
    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
   276
        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
   277
          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
   278
        , 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
   279
        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick $ fromJust newMaster]
13703
2df519242d41 Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents: 13696
diff changeset
   280
        -- TODO: Send message to other clients, too (requires proper localization, however)
2df519242d41 Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents: 13696
diff changeset
   281
        , AnswerClients [sendChan $ fromJust newMaster] ["CHAT", nickServer, loc "You're the new room master!"]
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
   282
        ]
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
   283
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
   284
    processAction $
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   285
        ModifyRoom (\r -> r{masterID = newMasterId
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   286
                , name = newRoomName
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   287
                , isRestrictedJoins = False
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   288
                , 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
   289
                , isRegisteredOnly = isSpecial r}
8983
a25e18295959 Restore ready toggle for room admins (issue 432)
unc0rr
parents: 8523
diff changeset
   290
                )
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   291
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   292
    newRoom' <- io $ room'sM rnc id ri
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   293
    chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   294
    let oldRoomNameByProto = roomNameByProto oldRoomName (roomProto newRoom')
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   295
    processAction $ AnswerClientsByProto chansProto (\p -> "ROOM" : "UPD" : oldRoomNameByProto p : roomInfo p (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
   296
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   297
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   298
processAction (AddRoom roomName roomPassword) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   299
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   300
    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
   301
    proto <- client's clientProto
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   302
    n <- client's nick
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   303
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   304
    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
   305
            masterID = Just clId,
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   306
            name = roomName,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   307
            password = roomPassword,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   308
            roomProto = proto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   309
            }
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   310
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   311
    rId <- io $ addRoom rnc rm
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   312
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   313
    processAction $ MoveToRoom rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   314
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   315
    chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   316
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   317
    mapM_ processAction [
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   318
      AnswerClientsByProto chansProto (\p -> "ROOM" : "ADD" : roomInfo p n rm{playersIn = 1})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   319
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   320
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   321
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   322
processAction RemoveRoom = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   323
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   324
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   325
    ri <- io $ clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   326
    roomName <- io $ room'sM rnc name ri
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   327
    roomProto <- io $ room'sM rnc roomProto ri
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   328
    others <- othersChansProto
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   329
    chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   330
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   331
    mapM_ processAction [
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   332
            AnswerClientsByProto chansProto (\p -> ["ROOM", "DEL", roomNameByProto roomName roomProto p]),
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   333
            AnswerClientsByProto others (\p -> ["ROOMABANDONED", roomNameByProto roomName roomProto p])
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   334
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   335
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   336
    io $ removeRoom rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   337
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   338
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   339
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
   340
    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
   341
    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
   342
    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
   343
    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
   344
    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
   345
    masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm)
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   346
    chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   347
    let thisRoomNameByProto = roomNameByProto (name rm) (roomProto rm)
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   348
    processAction $ AnswerClientsByProto chansProto (\p -> "ROOM" : "UPD" : thisRoomNameByProto p : roomInfo p (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
   349
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   350
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
   351
processAction UnreadyRoomClients = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   352
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   353
    roomPlayers <- roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   354
    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
   355
    mapM_ processAction [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   356
        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
   357
        , ModifyRoomClients (\cl -> cl{isReady = isMaster cl, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   358
        , 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
   359
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   360
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   361
        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   362
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   363
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
   364
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
   365
    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
   366
    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
   367
    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
   368
    joinedMidGame <- liftM (filter isJoinedMidGame) $ roomClientsS ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   369
    answerRemovedTeams <- io $
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   370
         room'sM rnc (\r -> let gi = fromJust $ gameInfo r in
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   371
                        concatMap (\c ->
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   372
                            (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
   373
                            ++
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   374
                            (map (\t -> AnswerClients [sendChan c] ["REMOVE_TEAM", t]) $ leftTeams gi)
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   375
                        ) joinedMidGame
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   376
                     ) ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   377
10814
810ac1d21fd0 This should help with second rejoin bug. (reverting previous workaround over frontend bug and making a new one)
unc0rr
parents: 10786
diff changeset
   378
    rteams <- io $ room'sM rnc (L.nub . rejoinedTeams . fromJust . gameInfo) ri
810ac1d21fd0 This should help with second rejoin bug. (reverting previous workaround over frontend bug and making a new one)
unc0rr
parents: 10786
diff changeset
   379
    mapM_ (processAction . RemoveTeam) rteams
810ac1d21fd0 This should help with second rejoin bug. (reverting previous workaround over frontend bug and making a new one)
unc0rr
parents: 10786
diff changeset
   380
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   381
    mapM_ processAction $ (
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   382
        SaveReplay
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   383
        : 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
   384
            (\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
   385
                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
   386
                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
   387
                }
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
   388
            )
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   389
        : SendUpdateOnThisRoom
8241
b15f165c080c Send "ROUND_FINISHED" to room clients when server thinks so
unc0rr
parents: 8239
diff changeset
   390
        : AnswerClients thisRoomChans ["ROUND_FINISHED"]
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   391
        : answerRemovedTeams
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   392
        )
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9062
diff changeset
   393
        ++ [UnreadyRoomClients]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   394
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   395
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
   396
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
   397
    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
   398
    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
   399
        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
   400
        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
   401
                gameInfo = liftM (\g -> g{
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   402
                    teamsInGameNumber = teamsInGameNumber g - 1
10944
c4b3440eeac6 - Fix order of messages, also don't duplicate last timestamped message
unc0rr
parents: 10814
diff changeset
   403
                    , lastFilteredTimedMsg = Nothing
c4b3440eeac6 - Fix order of messages, also don't duplicate last timestamped message
unc0rr
parents: 10814
diff changeset
   404
                    , roundMsgs = (if isJust $ lastFilteredTimedMsg g then ((:) rmTeamMsg . (:) (fromJust $ lastFilteredTimedMsg g)) else ((:) rmTeamMsg)) 
c4b3440eeac6 - Fix order of messages, also don't duplicate last timestamped message
unc0rr
parents: 10814
diff changeset
   405
                        $ 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
   406
                }) $ 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
   407
            })
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
   408
        ]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   409
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
   410
    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
   411
    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
   412
    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
   413
    when (0 == teamsInGameNumber (fromJust gi)) $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   414
        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
   415
    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
   416
        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   417
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   418
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   419
processAction (RemoveTeam teamName) = do
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   420
    (Just ci) <- gets clientIndex
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   421
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   422
    ri <- clientRoomA
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   423
    inGame <- io $ do
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   424
        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
   425
        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
   426
        return $ r && c
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   427
    chans <- othersChans
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   428
    mapM_ processAction $
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   429
        ModifyRoom (\r -> r{
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   430
            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
   431
            , 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
   432
            })
7947
0cf5277fef1a Better place for SendUpdateOnThisRoom
unc0rr
parents: 7945
diff changeset
   433
        : SendUpdateOnThisRoom
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   434
        : AnswerClients chans ["REMOVE_TEAM", teamName]
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   435
        : [SendTeamRemovalMessage teamName | inGame]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   436
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   437
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   438
processAction RemoveClientTeams = do
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   439
    (Just ci) <- gets clientIndex
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   440
    rnc <- gets roomsClients
10732
7c4f9e5e447c Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents: 10460
diff changeset
   441
    n <- client's nick
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   442
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   443
    removeTeamActions <- io $ do
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   444
        rId <- clientRoomM rnc ci
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   445
        roomTeams <- room'sM rnc teams rId
10732
7c4f9e5e447c Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents: 10460
diff changeset
   446
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == n) $ roomTeams
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   447
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   448
    mapM_ processAction removeTeamActions
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   449
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   450
10786
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   451
processAction SetRandomSeed = do
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   452
    ri <- clientRoomA
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   453
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   454
    seed <- liftM showB $ io $ (randomRIO (0, 10^9) :: IO Int)
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   455
    mapM_ processAction [
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   456
        ModifyRoom (\r -> r{mapParams = Map.insert "SEED" seed $ mapParams r})
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   457
        , AnswerClients thisRoomChans ["CFG", "SEED", seed]
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   458
        ]
712283ed86e0 Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents: 10732
diff changeset
   459
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   460
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   461
processAction CheckRegistered = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   462
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   463
    n <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   464
    h <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   465
    p <- client's clientProto
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   466
    checker <- client's isChecker
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   467
    uid <- client's clUID
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   468
    -- allow multiple checker logins
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   469
    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
   470
    if (not checker) && haveSameNick then
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   471
        if p < 38 then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   472
            processAction $ ByeClient $ loc "Nickname is already in use"
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   473
            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
   474
            mapM_ processAction [NoticeMessage NickAlreadyInUse, ModifyClient $ \c -> c{nick = B.empty}]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   475
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   476
        do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   477
        db <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   478
        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   479
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   480
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   481
processAction ClearAccountsCache = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   482
    dbq <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   483
    io $ writeChan dbq ClearCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   484
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   485
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   486
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   487
processAction (ProcessAccountInfo info) = do
11465
0ae2e4c13bd1 Allow toggling registration requirement on live server
unc0rr
parents: 11463
diff changeset
   488
    si <- gets serverInfo
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   489
    case info of
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   490
        HasAccount passwd isAdmin isContr -> do
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   491
            b <- isBanned
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   492
            c <- client's isChecker
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   493
            when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin isContr
11465
0ae2e4c13bd1 Allow toggling registration requirement on live server
unc0rr
parents: 11463
diff changeset
   494
        Guest | isRegisteredUsersOnly si -> do
13728
3106d630d6b5 Make guest rejection error translatable
Wuzzy <Wuzzy2@mail.ru>
parents: 13703
diff changeset
   495
            processAction $ ByeClient $ loc "This server only allows registered users to join."
11465
0ae2e4c13bd1 Allow toggling registration requirement on live server
unc0rr
parents: 11463
diff changeset
   496
            | otherwise -> do
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   497
            b <- isBanned
8523
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   498
            c <- client's isChecker
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   499
            when (not b) $
8523
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   500
                if c then
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   501
                    checkerLogin "" False False
8523
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   502
                    else
f13ae07d82d7 Forbit guest checkers
unc0rr
parents: 8519
diff changeset
   503
                    processAction JoinLobby
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   504
        Admin ->
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   505
            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   506
        ReplayName fn -> processAction $ ShowReplay fn
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   507
    where
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   508
    isBanned = do
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   509
        processAction $ CheckBanned False
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   510
        liftM B.null $ client's nick
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   511
    checkerLogin _ False _ = processAction $ ByeClient $ loc "No checker rights"
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   512
    checkerLogin p True _ = do
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   513
        wp <- client's webPassword
10014
56d2f2d5aad8 Fix checker logon process
Wohlstand
parents: 9973
diff changeset
   514
        chan <- client's sendChan
56d2f2d5aad8 Fix checker logon process
Wohlstand
parents: 9973
diff changeset
   515
        mapM_ processAction $
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   516
            if wp == p then
10014
56d2f2d5aad8 Fix checker logon process
Wohlstand
parents: 9973
diff changeset
   517
                [ModifyClient $ \c -> c{logonPassed = True}
56d2f2d5aad8 Fix checker logon process
Wohlstand
parents: 9973
diff changeset
   518
                , AnswerClients [chan] ["LOGONPASSED"]
56d2f2d5aad8 Fix checker logon process
Wohlstand
parents: 9973
diff changeset
   519
                ]
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   520
                else
10014
56d2f2d5aad8 Fix checker logon process
Wohlstand
parents: 9973
diff changeset
   521
                [ByeClient $ loc "Authentication failed"]
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   522
    playerLogin p a contr = do
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 10058
diff changeset
   523
        cl <- client's id
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   524
        mapM_ processAction [
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 10058
diff changeset
   525
            AnswerClients [sendChan cl] $ ("ASKPASSWORD") : if clientProto cl < 48 then [] else [serverSalt cl]
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   526
            , ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr})
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   527
            ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   528
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   529
processAction JoinLobby = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   530
    chan <- client's sendChan
9528
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   531
    rnc <- gets roomsClients
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   532
    clientNick <- client's nick
11463
fe46826de291 Don't send LIST command on join
unc0rr
parents: 11341
diff changeset
   533
    clProto <- client's clientProto
12761
0167e337553b Use maybeNick from Utils, fixes empty nickname inserted in ROOMS protocol command parameters. Not tested, but builds, and it's Haskell...
unc0rr
parents: 12114
diff changeset
   534
    isAuthenticated <- client's isRegistered
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   535
    isAdmin <- client's isAdministrator
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   536
    isContr <- client's isContributor
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   537
    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
   538
    let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
12114
cdadc1d487f1 Only registered players regain their teams on rejoin
unc0rr
parents: 11854
diff changeset
   539
    let authenticatedNicks = L.map nick . L.filter isRegistered $ loggedInClients
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   540
    let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   541
    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
   542
    inRoomNicks <- io $
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   543
        allClientsM rnc
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   544
        >>= filterM (liftM ((/=) lobbyId) . clientRoomM rnc)
9351e96990ae Send +i status of all players to logged-in users
unc0rr
parents: 9448
diff changeset
   545
        >>= mapM (client'sM rnc nick)
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   546
    let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin], ["c" | isContr]]
11463
fe46826de291 Don't send LIST command on join
unc0rr
parents: 11341
diff changeset
   547
fe46826de291 Don't send LIST command on join
unc0rr
parents: 11341
diff changeset
   548
    roomsInfoList <- io $ do
fe46826de291 Don't send LIST command on join
unc0rr
parents: 11341
diff changeset
   549
        rooms <- roomsM rnc
12761
0167e337553b Use maybeNick from Utils, fixes empty nickname inserted in ROOMS protocol command parameters. Not tested, but builds, and it's Haskell...
unc0rr
parents: 12114
diff changeset
   550
        mapM (\r -> (mapM (client'sM rnc id) $ masterID r)
0167e337553b Use maybeNick from Utils, fixes empty nickname inserted in ROOMS protocol command parameters. Not tested, but builds, and it's Haskell...
unc0rr
parents: 12114
diff changeset
   551
            >>= \cn -> return $ roomInfo clProto (maybeNick cn) r)
15878
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 15788
diff changeset
   552
            $ filter ((/=) 0 . roomProto) rooms
11463
fe46826de291 Don't send LIST command on join
unc0rr
parents: 11341
diff changeset
   553
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   554
    mapM_ processAction . concat $ [
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   555
        [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   556
        , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   557
        , [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
   558
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   559
        , [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
   560
        , [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
   561
        , [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
   562
        , [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
   563
        , [SendServerMessage]
11463
fe46826de291 Don't send LIST command on join
unc0rr
parents: 11341
diff changeset
   564
        , [AnswerClients [chan] ("ROOMS" : concat roomsInfoList)]
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   565
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   566
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   567
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   568
processAction (KickClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   569
    modify (\s -> s{clientIndex = Just kickId})
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   570
    clHost <- client's host
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   571
    currentTime <- io getCurrentTime
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   572
    mapM_ processAction [
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   573
        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
   574
        , ModifyClient (\c -> c{isKickedFromServer = True})
13657
2d38dc2d3414 Tweak some connection failure messages
Wuzzy <Wuzzy2@mail.ru>
parents: 13506
diff changeset
   575
        , ByeClient $ loc "Kicked"
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   576
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   577
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   578
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   579
processAction (BanClient seconds reason banId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   580
    modify (\s -> s{clientIndex = Just banId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   581
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   582
    currentTime <- io getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   583
    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   584
    mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   585
        AddIP2Bans clHost msg (addUTCTime seconds currentTime)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   586
        , KickClient banId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   587
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   588
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   589
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   590
processAction (BanIP ip seconds reason) = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   591
    currentTime <- io getCurrentTime
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   592
    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
   593
    processAction $
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   594
        AddIP2Bans ip msg (addUTCTime seconds currentTime)
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   595
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   596
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   597
processAction (BanNick n seconds reason) = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   598
    currentTime <- io getCurrentTime
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   599
    let msg =
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   600
            if seconds > 60 * 60 * 24 * 365 then
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   601
                B.concat ["Permanent ban (", reason, ")"]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   602
                else
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   603
                B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   604
    processAction $
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   605
        AddNick2Bans n msg (addUTCTime seconds currentTime)
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   606
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   607
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   608
processAction BanList = do
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   609
    time <- io $ getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   610
    ch <- client's sendChan
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   611
    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
   612
    processAction $
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   613
        AnswerClients [ch] ["BANLIST", b]
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   614
    where
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   615
        ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time]
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   616
        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
   617
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   618
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   619
processAction (Unban entry) = do
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   620
    processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s})
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   621
    where
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   622
        f (BanByIP bip _ _) = bip == entry
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   623
        f (BanByNick bn _ _) = bn == entry
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   624
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   625
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   626
processAction (KickRoomClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   627
    modify (\s -> s{clientIndex = Just kickId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   628
    ch <- client's sendChan
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   629
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]
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 (AddClient cl) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   633
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   634
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   635
    newClId <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   636
        ci <- addClient rnc cl
10259
c85d241d9cc9 committing patch from issue 798, as requested by unC0Rr
sheepluva
parents: 10216
diff changeset
   637
        _ <- Exception.mask (\x -> forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci x)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   638
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   639
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   640
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   641
        return ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   642
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   643
    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
   644
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   645
    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
   646
    pass <- io $ joinsSentry jm (host cl) (connectTime cl)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   647
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   648
    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
   649
        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
   650
            [
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   651
                CheckBanned True
13506
36f3f77e9b1b Switch from http:// to https:// URLs where possible
Wuzzy <Wuzzy2@mail.ru>
parents: 13418
diff changeset
   652
                , AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server https://www.hedgewars.org/", serverVersion]
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   653
            ]
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   654
        else
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   655
        processAction $ ByeClient $ loc "Reconnected too fast"
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   656
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   657
processAction (AddNick2Bans n reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   658
    processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   659
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   660
processAction (AddIP2Bans ip reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   661
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   662
    rc <- gets removedClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   663
    when (not $ ci `Set.member` rc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   664
        $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   665
8519
98e2dbdda8c0 Workaround desync issue if I correctly understand its roots (barely tested)
unc0rr
parents: 8514
diff changeset
   666
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   667
processAction (CheckBanned byIP) = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   668
    clTime <- client's connectTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   669
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   670
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   671
    si <- gets serverInfo
10148
a599593e1dc2 Don't rewrite server ini file too often
unc0rr
parents: 10095
diff changeset
   672
    let (validBans, expiredBans) = L.partition (checkNotExpired clTime) $ bans si
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   673
    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
   674
    mapM_ processAction $
10148
a599593e1dc2 Don't rewrite server ini file too often
unc0rr
parents: 10095
diff changeset
   675
        [ModifyServerInfo (\s -> s{bans = validBans}) | not $ null expiredBans]
a599593e1dc2 Don't rewrite server ini file too often
unc0rr
parents: 10095
diff changeset
   676
        ++ [ByeClient (getBanReason $ fromJust ban) | isJust ban]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   677
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   678
        checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   679
        checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
11854
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
   680
        checkBan True ip _ (BanByIP bip _ _) = isMatch bip ip
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
   681
        checkBan False _ n (BanByNick bn _ _) = isMatch bn n
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   682
        checkBan _ _ _ _ = False
11854
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
   683
        isMatch :: B.ByteString -> B.ByteString -> Bool
14685
669eb45bda72 revert bc267f6b29d7
alfadur
parents: 14684
diff changeset
   684
        isMatch rexp src = (==) (Just True) $ mrexp rexp >>= flip matchM src
11854
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
   685
        mrexp :: B.ByteString -> Maybe TDFAB.Regex
0b8f2116aa26 Use regex match for bans
unc0rr
parents: 11581
diff changeset
   686
        mrexp = makeRegexOptsM TDFA.defaultCompOpt{TDFA.caseSensitive = False} TDFA.defaultExecOpt
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   687
        getBanReason (BanByIP _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   688
        getBanReason (BanByNick _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   689
8519
98e2dbdda8c0 Workaround desync issue if I correctly understand its roots (barely tested)
unc0rr
parents: 8514
diff changeset
   690
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   691
processAction PingAll = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   692
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   693
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   694
    cis <- io $ allClientsM rnc
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   695
    chans <- io $ mapM (client'sM rnc sendChan) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   696
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   697
    processAction $ AnswerClients chans ["PING"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   698
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   699
        kickTimeouted rnc ci = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   700
            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
   701
            when (pq > 0) $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   702
                withStateT (\as -> as{clientIndex = Just ci}) $
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   703
                    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
   704
--                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
   705
--                    processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   706
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   707
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   708
processAction StatsAction = do
5211
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   709
    si <- gets serverInfo
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   710
    when (not $ shutdownPending si) $ do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   711
        rnc <- gets roomsClients
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   712
        (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   713
        io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   714
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   715
          st irnc = (length $ allRooms irnc, length $ allClients irnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   716
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   717
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   718
processAction RestartServer = do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   719
    sp <- gets (shutdownPending . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   720
    when (not sp) $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   721
        sock <- gets (fromJust . serverSocket . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   722
        args <- gets (runArgs . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   723
        io $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   724
            noticeM "Core" "Closing listening socket"
15699
27eb5abd5058 update server network
Jens Petersen
parents: 15408
diff changeset
   725
            close sock
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   726
            noticeM "Core" "Spawning new server"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   727
            _ <- createProcess (proc "./hedgewars-server" args)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   728
            return ()
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   729
        processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   730
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9433
diff changeset
   731
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   732
processAction Stats = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   733
    cls <- allClientsS
8452
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   734
    rms <- allRoomsS
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   735
    let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   736
    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
   737
    let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   738
    let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"])
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   739
            . concatMap (\p -> [
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   740
                    "<tr><td>", protoNumber2ver p
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   741
                    , "</td><td>", showB $ Map.findWithDefault 0 p clientsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   742
                    , "</td><td>", showB $ Map.findWithDefault 0 p roomsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   743
                    , "</td></tr>"])
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   744
            . Set.toList $ keys
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   745
    processAction $ Warning versionsStats
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   746
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   747
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   748
processAction (Random chans items) = do
13730
5f62417a7d84 Translate "heads" and "tails" of gameServer
Wuzzy <Wuzzy2@mail.ru>
parents: 13728
diff changeset
   749
    let i = if null items then [loc "heads", loc "tails"] else items
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   750
    n <- io $ randomRIO (0, length i - 1)
13730
5f62417a7d84 Translate "heads" and "tails" of gameServer
Wuzzy <Wuzzy2@mail.ru>
parents: 13728
diff changeset
   751
    processAction $ AnswerClients chans ["CHAT", if null items then nickRandomCoin else nickRandomCustom, i !! n]
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   752
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9032
diff changeset
   753
11575
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   754
processAction (LoadGhost location) = do
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   755
    ri <- clientRoomA
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   756
    rnc <- gets roomsClients
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   757
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
11581
fd02a080d962 - Fix room config being sent unmodified
unc0rr
parents: 11580
diff changeset
   758
#if defined(OFFICIAL_SERVER)
11577
bee3a2f8e117 Finish implementation of ghost points served from server, not tested
unc0rr
parents: 11575
diff changeset
   759
    rm <- io $ room'sM rnc id ri
11580
c8edd93b970f Fix build
unc0rr
parents: 11577
diff changeset
   760
    points <- io $ loadFile (B.unpack $ "ghosts/" `B.append` sanitizeName location)
11577
bee3a2f8e117 Finish implementation of ghost points served from server, not tested
unc0rr
parents: 11575
diff changeset
   761
    when (roomProto rm > 51) $ do
bee3a2f8e117 Finish implementation of ghost points served from server, not tested
unc0rr
parents: 11575
diff changeset
   762
        processAction $ ModifyRoom $ \r -> r{params = Map.insert "DRAWNMAP" [prependGhostPoints (toP points) $ head $ (params r) Map.! "DRAWNMAP"] (params r)}
11580
c8edd93b970f Fix build
unc0rr
parents: 11577
diff changeset
   763
#endif
11575
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   764
    cl <- client's id
11581
fd02a080d962 - Fix room config being sent unmodified
unc0rr
parents: 11580
diff changeset
   765
    rm <- io $ room'sM rnc id ri
11577
bee3a2f8e117 Finish implementation of ghost points served from server, not tested
unc0rr
parents: 11575
diff changeset
   766
    mapM_ processAction $ map (replaceChans thisRoomChans) $ answerFullConfigParams cl (mapParams rm) (params rm)
11575
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   767
    where
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   768
    loadFile :: String -> IO [Int]
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   769
    loadFile fileName = E.handle (\(e :: SomeException) -> return []) $ do
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   770
        points <- liftM read $ readFile fileName
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   771
        return (points `deepseq` points)
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   772
    replaceChans chans (AnswerClients _ msg) = AnswerClients chans msg
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   773
    replaceChans _ a = a
11577
bee3a2f8e117 Finish implementation of ghost points served from server, not tested
unc0rr
parents: 11575
diff changeset
   774
    toP [] = []
bee3a2f8e117 Finish implementation of ghost points served from server, not tested
unc0rr
parents: 11575
diff changeset
   775
    toP (p1:p2:ps) = (fromIntegral p1, fromIntegral p2) : toP ps
11575
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   776
{-
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   777
        let a = map (replaceChans chans) $ answerFullConfigParams cl mp p
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   778
-}
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   779
#if defined(OFFICIAL_SERVER)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   780
processAction SaveReplay = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   781
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   782
    rnc <- gets roomsClients
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   783
9437
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
   784
    readyCheckersIds <- io $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   785
        r <- room'sM rnc id ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   786
        saveReplay r
9437
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
   787
        allci <- allClientsM rnc
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
   788
        filterM (client'sM rnc isReadyChecker) allci
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   789
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   790
    when (not $ null readyCheckersIds) $ do
9439
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   791
        oldci <- gets clientIndex
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   792
        withStateT (\s -> s{clientIndex = Just $ head readyCheckersIds})
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   793
            $ processAction CheckRecord
e0570f2e5f41 Unbreak server
unc0rr
parents: 9437
diff changeset
   794
        modify (\s -> s{clientIndex = oldci})
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   795
    where
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   796
        isReadyChecker cl = isChecker cl && isReady cl
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   797
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   798
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   799
processAction CheckRecord = do
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   800
    p <- client's clientProto
8482
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
   801
    c <- client's sendChan
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   802
    ri <- clientRoomA
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   803
    rnc <- gets roomsClients
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   804
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   805
    blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   806
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 9528
diff changeset
   807
    (cinfo, l) <- io $ loadReplay (fromIntegral p) blackList
10086
4a7ce724357f This should help server bypass malformed replays
unc0rr
parents: 10076
diff changeset
   808
    when (isJust cinfo) $
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   809
        mapM_ processAction [
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   810
            AnswerClients [c] ("REPLAY" : l)
9444
30748b1d9ec7 Fix checker ready status mess
unc0rr
parents: 9439
diff changeset
   811
            , ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False}
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   812
            ]
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   813
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   814
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   815
processAction (CheckFailed msg) = do
11246
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11046
diff changeset
   816
    Just (CheckInfo fileName _ _) <- client's checkInfo
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   817
    io $ moveFailedRecord fileName
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   818
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9401
diff changeset
   819
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   820
processAction (CheckSuccess info) = do
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11246
diff changeset
   821
    Just (CheckInfo fileName teams gameDetails) <- client's checkInfo
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9786
diff changeset
   822
    p <- client's clientProto
9401
2af7bea32e5e - Some fixes to official server build
unc0rr
parents: 9399
diff changeset
   823
    si <- gets serverInfo
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11246
diff changeset
   824
    when (isJust gameDetails)
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11246
diff changeset
   825
        $ io $ writeChan (dbQueries si) $ StoreAchievements p (B.pack fileName) (map toPair teams) (fromJust gameDetails) info
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   826
    io $ moveCheckedRecord fileName
9399
1767c92eff37 Pass achievements info to extdbinterface
unc0rr
parents: 9381
diff changeset
   827
    where
1767c92eff37 Pass achievements info to extdbinterface
unc0rr
parents: 9381
diff changeset
   828
        toPair t = (teamname t, teamowner t)
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   829
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   830
processAction (QueryReplay rname) = do
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   831
    (Just ci) <- gets clientIndex
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   832
    si <- gets serverInfo
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   833
    uid <- client's clUID
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   834
    io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) rname
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   835
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   836
processAction (ShowReplay rname) = do
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   837
    c <- client's sendChan
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   838
    cl <- client's id
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   839
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   840
    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
   841
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   842
    cInfo <- liftIO $ E.handle (\(e :: SomeException) ->
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   843
                    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
   844
            (t, p1, p2, msgs) <- liftM read $ readFile (B.unpack fileName)
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   845
            return $ Just (t, Map.fromList p1, Map.fromList p2, reverse msgs)
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9444
diff changeset
   846
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   847
    let (teams', params1, params2, roundMsgs') = fromJust cInfo
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   848
9786
e33ee5ef5d9d - Remove obsolete protocol message
unc0rr
parents: 9753
diff changeset
   849
    when (isJust cInfo) $ do
14905
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   850
        mapM_ processAction $
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   851
            if clientProto cl < 58 then
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   852
                concat [
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   853
                    [AnswerClients [c] ["JOINED", nick cl]]
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   854
                    , answerFullConfigParams cl params1 params2
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   855
                    , answerAllTeams cl teams'
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   856
                    , [AnswerClients [c]  ["RUN_GAME"]]
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   857
                    , [AnswerClients [c] $ "EM" : roundMsgs']
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   858
                    , [AnswerClients [c] ["KICKED"]]
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   859
                ]
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   860
            else
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   861
                concat [
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   862
                    [AnswerClients [c] ["REPLAY_START"]]
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   863
                    , answerFullConfigParams cl params1 params2
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   864
                    , answerAllTeams cl teams'
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   865
                    , [AnswerClients [c]  ["RUN_GAME"]]
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   866
                    , [AnswerClients [c] $ "EM" : roundMsgs']
6b591186ab10 Server /watch: Add back KICKED for old clients, remove REPLAY_START parameter
Wuzzy <Wuzzy2@mail.ru>
parents: 14904
diff changeset
   867
                ]
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   868
10195
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   869
processAction (SaveRoom rname) = do
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   870
    rnc <- gets roomsClients
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   871
    ri <- clientRoomA
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   872
    rm <- io $ room'sM rnc id ri
13418
bb24c3414b0d Store saved room in yaml
unc0rr
parents: 12864
diff changeset
   873
    liftIO $ YAML.encodeFile (B.unpack rname) (greeting rm, roomSaves rm)
10195
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   874
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   875
processAction (LoadRoom rname) = do
13418
bb24c3414b0d Store saved room in yaml
unc0rr
parents: 12864
diff changeset
   876
    Right (g, rs) <- io $ YAML.decodeFileEither (B.unpack rname)
10195
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10148
diff changeset
   877
    processAction $ ModifyRoom $ \r -> r{greeting = g, roomSaves = rs}
14359
5e28098fb593 Fix stray tab character
unc0rr
parents: 14287
diff changeset
   878
14287
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   879
#else
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   880
processAction SaveReplay = return ()
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   881
processAction CheckRecord = return ()
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   882
processAction (CheckFailed _) = return ()
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   883
processAction (CheckSuccess _) = return ()
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   884
processAction (QueryReplay _) = processAction $ Warning $ loc "This server does not support replays!"
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   885
processAction (ShowReplay rname) = return ()
15408
d9a12aba5c05 GameServer: Hide saveroom and loadroom command in non-official server
Wuzzy <Wuzzy2@mail.ru>
parents: 14905
diff changeset
   886
processAction (SaveRoom rname) = return () -- TODO: Send warning that this command is unsupported
d9a12aba5c05 GameServer: Hide saveroom and loadroom command in non-official server
Wuzzy <Wuzzy2@mail.ru>
parents: 14905
diff changeset
   887
processAction (LoadRoom rname) = return () -- TODO: Send warning that this command is unsupported
14287
9f0d81213d65 Cut dependency on yaml for non-official server builds
unC0Rr
parents: 13730
diff changeset
   888
#endif
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   889
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   890
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
   891
    jm <- gets joinsMonitor
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 10015
diff changeset
   892
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 9868
diff changeset
   893
    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
   894
        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
   895
        cleanup jm t
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents: 10086
diff changeset
   896
a471a7bbc339 - Start work on flood detector
unc0rr
parents: 10086
diff changeset
   897
a471a7bbc339 - Start work on flood detector
unc0rr
parents: 10086
diff changeset
   898
processAction (RegisterEvent e) = do
a471a7bbc339 - Start work on flood detector
unc0rr
parents: 10086
diff changeset
   899
    actions <- registerEvent e
a471a7bbc339 - Start work on flood detector
unc0rr
parents: 10086
diff changeset
   900
    mapM_ processAction actions
10212
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   901
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   902
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   903
processAction (ReactCmd cmd) = do
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   904
    (Just ci) <- gets clientIndex
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   905
    rnc <- gets roomsClients
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   906
    actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10195
diff changeset
   907
    forM_ (actions `deepseq` actions) processAction
10215
26fc5502ba22 - Fix applying vote result
unc0rr
parents: 10212
diff changeset
   908
26fc5502ba22 - Fix applying vote result
unc0rr
parents: 10212
diff changeset
   909
processAction CheckVotes =
11575
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11465
diff changeset
   910
    checkVotes >>= mapM_ processAction
14380
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   911
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   912
processAction (ShowRegisteredOnlyState chans) = do
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   913
    si <- gets serverInfo
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   914
    processAction $ AnswerClients chans
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   915
        ["CHAT", nickServer,
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   916
        if isRegisteredUsersOnly si then
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   917
            loc "This server no longer allows unregistered players to join."
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   918
        else
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   919
            loc "This server now allows unregistered players to join."
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14359
diff changeset
   920
        ]