gameServer/Actions.hs
author unc0rr
Mon, 18 Feb 2013 00:28:09 +0400
changeset 8510 0a39b2f9c748
parent 8509 eda9f2106d8d
child 8514 896b283f41a2
permissions -rw-r--r--
No NFData instance for ByteString when ghc >= 7.6
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
     1
{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
     2
{-# OPTIONS_GHC -fno-warn-orphans #-}
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     3
module Actions where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     4
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     5
import Control.Concurrent
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     6
import qualified Data.Set as Set
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
     7
import qualified Data.Map as Map
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     8
import qualified Data.List as L
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
     9
import qualified Control.Exception as Exception
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    10
import System.Log.Logger
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    11
import Control.Monad
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    12
import Data.Time
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    13
import Data.Maybe
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    14
import Control.Monad.Reader
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    15
import Control.Monad.State.Strict
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    16
import qualified Data.ByteString.Char8 as B
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    17
import Control.DeepSeq
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    18
import Data.Unique
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    19
import Control.Arrow
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    20
import Control.Exception
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    21
import System.Process
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    22
import Network.Socket
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    23
-----------------------------
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    24
#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
    25
import OfficialServer.GameReplayStore
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
    26
#endif
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    27
import CoreTypes
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    28
import Utils
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    29
import ClientIO
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    30
import ServerState
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    31
import Consts
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    32
import ConfigFile
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 6012
diff changeset
    33
import EngineInteraction
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    34
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    35
data Action =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    36
    AnswerClients ![ClientChan] ![B.ByteString]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    37
    | SendServerMessage
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    38
    | SendServerVars
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    39
    | MoveToRoom RoomIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    40
    | MoveToLobby B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    41
    | RemoveTeam B.ByteString
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
    42
    | SendTeamRemovalMessage B.ByteString
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    43
    | RemoveRoom
6758
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
    44
    | FinishGame
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    45
    | UnreadyRoomClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    46
    | JoinLobby
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    47
    | ProtocolError B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    48
    | Warning B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    49
    | NoticeMessage Notice
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    50
    | ByeClient B.ByteString
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    51
    | KickClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    52
    | KickRoomClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    53
    | BanClient NominalDiffTime B.ByteString ClientIndex
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
    54
    | BanIP B.ByteString NominalDiffTime B.ByteString
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
    55
    | BanNick B.ByteString NominalDiffTime B.ByteString
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
    56
    | BanList
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
    57
    | Unban B.ByteString
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8245
diff changeset
    58
    | ChangeMaster (Maybe ClientIndex)
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
    59
    | RemoveClientTeams
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    60
    | ModifyClient (ClientInfo -> ClientInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    61
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
    62
    | ModifyRoomClients (ClientInfo -> ClientInfo)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    63
    | ModifyRoom (RoomInfo -> RoomInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    64
    | ModifyServerInfo (ServerInfo -> ServerInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    65
    | AddRoom B.ByteString B.ByteString
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
    66
    | SendUpdateOnThisRoom
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    67
    | CheckRegistered
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    68
    | ClearAccountsCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    69
    | ProcessAccountInfo AccountInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    70
    | AddClient ClientInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    71
    | DeleteClient ClientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    72
    | PingAll
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    73
    | StatsAction
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
    74
    | RestartServer
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    75
    | AddNick2Bans B.ByteString B.ByteString UTCTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    76
    | AddIP2Bans B.ByteString B.ByteString UTCTime
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
    77
    | CheckBanned Bool
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    78
    | SaveReplay
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
    79
    | Stats
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
    80
    | CheckRecord
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
    81
    | CheckFailed B.ByteString
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
    82
    | CheckSuccess [B.ByteString]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    83
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    84
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    85
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    86
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    87
instance NFData Action where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    88
    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    89
    rnf a = a `seq` ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    90
8510
0a39b2f9c748 No NFData instance for ByteString when ghc >= 7.6
unc0rr
parents: 8509
diff changeset
    91
#if __GLASGOW_HASKELL__ < 706
8452
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
    92
instance NFData B.ByteString
8510
0a39b2f9c748 No NFData instance for ByteString when ghc >= 7.6
unc0rr
parents: 8509
diff changeset
    93
#endif
0a39b2f9c748 No NFData instance for ByteString when ghc >= 7.6
unc0rr
parents: 8509
diff changeset
    94
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    95
instance NFData (Chan a)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    96
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    97
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    98
othersChans :: StateT ServerState IO [ClientChan]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
    99
othersChans = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   100
    cl <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   101
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   102
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   103
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   104
processAction :: Action -> StateT ServerState IO ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   105
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   106
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   107
processAction (AnswerClients chans msg) =
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   108
    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   109
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   110
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   111
processAction SendServerMessage = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   112
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   113
    protonum <- client's clientProto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   114
    si <- liftM serverInfo get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   115
    let message = if protonum < latestReleaseVersion si then
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   116
            serverMessageForOldVersions si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   117
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   118
            serverMessage si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   119
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   120
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   121
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   122
processAction SendServerVars = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   123
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   124
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   125
    io $ writeChan chan ("SERVER_VARS" : vars si)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   126
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   127
        vars si = [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   128
            "MOTD_NEW", serverMessage si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   129
            "MOTD_OLD", serverMessageForOldVersions si,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   130
            "LATEST_PROTO", showB $ latestReleaseVersion si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   131
            ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   132
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   133
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   134
processAction (ProtocolError msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   135
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   136
    processAction $ AnswerClients [chan] ["ERROR", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   137
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   138
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   139
processAction (Warning msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   140
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   141
    processAction $ AnswerClients [chan] ["WARNING", msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   142
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   143
processAction (NoticeMessage n) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   144
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   145
    processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   146
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   147
processAction (ByeClient msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   148
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   149
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   150
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   151
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   152
    clNick <- client's nick
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   153
    loggedIn <- client's isVisible
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   154
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   155
    when (ri /= lobbyId) $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   156
        processAction $ MoveToLobby ("quit: " `B.append` msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   157
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   158
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   159
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   160
    io $
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   161
        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   162
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   163
    when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   164
8158
5da1c26d5b10 Fix warning
unc0rr
parents: 8156
diff changeset
   165
    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
   166
        [
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
   167
        AnswerClients [chan] ["BYE", msg]
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   168
        , ModifyClient (\c -> c{nick = "", isVisible = False}) -- this will effectively hide client from others while he isn't deleted from list
7465
c2dcf97ca664 Okay, this is workaround over ping timeouts problem on the server. Could make server crash if recieve thread wakes up after second ping timeout event.
unc0rr
parents: 7351
diff changeset
   169
        ]
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
   170
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   171
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   172
    put $! s{removedClients = ci `Set.insert` removedClients s}
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   173
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   174
processAction (DeleteClient ci) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   175
    io $ debugM "Clients"  $ "DeleteClient: " ++ show ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   176
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   177
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   178
    io $ removeClient rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   179
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   180
    s <- get
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   181
    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
   182
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   183
    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
   184
    cls <- allClientsS
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5184
diff changeset
   185
    io $ when (sp && null cls) $ throwIO ShutdownException
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   186
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   187
processAction (ModifyClient f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   188
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   189
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   190
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   191
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   192
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   193
processAction (ModifyClient2 ci f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   194
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   195
    io $ modifyClient rnc f ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   196
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   197
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   198
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
   199
    rnc <- gets roomsClients
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   200
    ri <- clientRoomA
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7748
diff changeset
   201
    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
   202
    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
   203
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   204
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   205
processAction (ModifyRoom f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   206
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   207
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   208
    io $ modifyRoom rnc f ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   209
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   210
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   211
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   212
processAction (ModifyServerInfo f) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   213
    modify (\s -> s{serverInfo = f $ serverInfo s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   214
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   215
    io $ writeServerConfig si
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   216
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   217
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   218
processAction (MoveToRoom ri) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   219
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   220
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   221
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   222
    io $ do
7898
ba735701ce7f Clear in-game flag when user joins room
unc0rr
parents: 7775
diff changeset
   223
        modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False, isInGame = False}) ci
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   224
        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   225
        moveClientToRoom rnc ri ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   226
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   227
    chans <- liftM (map sendChan) $ roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   228
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   229
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   230
    processAction $ AnswerClients chans ["JOINED", clNick]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   231
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   232
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   233
processAction (MoveToLobby msg) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   234
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   235
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   236
    rnc <- gets roomsClients
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   237
    playersNum <- io $ room'sM rnc playersIn ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   238
    master <- client's isMaster
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   239
--    client <- client's id
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   240
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   241
    chans <- othersChans
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   242
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   243
    if master then
7521
093ea41051c5 Keep room till last player quits
unc0rr
parents: 7498
diff changeset
   244
        if playersNum > 1 then
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   245
            mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   246
            else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   247
            processAction RemoveRoom
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   248
        else
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   249
        mapM_ processAction [RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   250
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   251
    -- 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
   252
    ready <- client's isReady
7521
093ea41051c5 Keep room till last player quits
unc0rr
parents: 7498
diff changeset
   253
    when (not master || playersNum > 1) . io $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   254
        modifyRoom rnc (\r -> r{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   255
                playersIn = playersIn r - 1,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   256
                readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   257
                }) ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   258
        moveClientToLobby rnc ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   259
7710
fd5bcbd698a5 - Keep track of room name so correct name is displayed when you become room admin
unc0rr
parents: 7682
diff changeset
   260
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8245
diff changeset
   261
processAction (ChangeMaster delegateId)= do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   262
    (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
   263
    proto <- client's clientProto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   264
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   265
    rnc <- gets roomsClients
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8245
diff changeset
   266
    newMasterId <- liftM (\ids -> fromMaybe (last . filter (/= ci) $ ids) delegateId) . io $ roomClientsIndicesM rnc ri
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   267
    newMaster <- io $ client'sM rnc id newMasterId
6733
5abbc345a82f Handle ROOM* commands in rooms list model
unc0rr
parents: 6541
diff changeset
   268
    oldRoomName <- io $ room'sM rnc name ri
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   269
    oldMaster <- client's nick
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   270
    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
   271
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   272
    let newRoomName = if (proto < 42) || kicked then nick newMaster else oldRoomName
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   273
    mapM_ processAction [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   274
        ModifyRoom (\r -> r{masterID = newMasterId
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   275
                , name = newRoomName
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   276
                , isRestrictedJoins = False
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   277
                , isRestrictedTeams = False
8232
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   278
                , isRegisteredOnly = False
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   279
                , readyPlayers = if isReady newMaster then readyPlayers r else readyPlayers r + 1})
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   280
        , ModifyClient2 newMasterId (\c -> c{isMaster = True, isReady = True})
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   281
        , AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7668
diff changeset
   282
        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMaster]
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   283
        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+hr", nick newMaster]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   284
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   285
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   286
    newRoom' <- io $ room'sM rnc id ri
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   287
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
7972
0dffb91eeb82 Oops, fix room info on room admin change
unc0rr
parents: 7947
diff changeset
   288
    processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo (nick newMaster) newRoom')
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   289
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   290
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   291
processAction (AddRoom roomName roomPassword) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   292
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   293
    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
   294
    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
   295
    n <- client's nick
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   296
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   297
    let rm = newRoom{
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   298
            masterID = clId,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   299
            name = roomName,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   300
            password = roomPassword,
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   301
            roomProto = proto
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   302
            }
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   303
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   304
    rId <- io $ addRoom rnc rm
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   305
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   306
    processAction $ MoveToRoom rId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   307
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
   308
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   309
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   310
    mapM_ processAction [
7945
4006d77e1a28 Send notification about 1 player in room on room creation
unc0rr
parents: 7926
diff changeset
   311
      AnswerClients chans ("ROOM" : "ADD" : roomInfo n rm{playersIn = 1})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   312
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   313
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   314
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   315
processAction RemoveRoom = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   316
    Just clId <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   317
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   318
    ri <- io $ clientRoomM rnc clId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   319
    roomName <- io $ room'sM rnc name ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   320
    others <- othersChans
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   321
    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
   322
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   323
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   324
    mapM_ processAction [
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
   325
            AnswerClients chans ["ROOM", "DEL", roomName],
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   326
            AnswerClients others ["ROOMABANDONED", roomName]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   327
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   328
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   329
    io $ removeRoom rnc ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   330
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   331
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   332
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
   333
    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
   334
    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
   335
    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
   336
    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
   337
    rm <- io $ room'sM rnc id ri
7926
550083f61a0e oops, fix incorrect room owner name in ROOM UPD command again
unc0rr
parents: 7924
diff changeset
   338
    n <- io $ client'sM rnc nick (masterID rm)
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   339
    chans <- liftM (map sendChan) $! sameProtoClientsS proto
7924
351f970c60e1 oops, fix incorrect room owner name in ROOM UPD command
unc0rr
parents: 7921
diff changeset
   340
    processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo n 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
   341
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   342
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
   343
processAction UnreadyRoomClients = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   344
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   345
    roomPlayers <- roomClientsS ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   346
    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
   347
    mapM_ processAction [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   348
        AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr . map nick . filter (not . isMaster) $ roomPlayers
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   349
        , ModifyRoomClients (\cl -> cl{isReady = isMaster cl})
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   350
        , 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
   351
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   352
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   353
        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   354
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   355
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
   356
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
   357
    rnc <- gets roomsClients
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   358
    ri <- clientRoomA
26bf919aeb57 Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents: 6756
diff changeset
   359
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   360
    answerRemovedTeams <- io $
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   361
         room'sM rnc (map (\t -> AnswerClients thisRoomChans ["REMOVE_TEAM", t]) . leftTeams . fromJust . gameInfo) ri
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   362
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   363
    mapM_ processAction $
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   364
        SaveReplay
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   365
        : 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
   366
            (\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
   367
                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
   368
                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
   369
                }
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
   370
            )
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   371
        : UnreadyRoomClients
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7898
diff changeset
   372
        : SendUpdateOnThisRoom
8241
b15f165c080c Send "ROUND_FINISHED" to room clients when server thinks so
unc0rr
parents: 8239
diff changeset
   373
        : AnswerClients thisRoomChans ["ROUND_FINISHED"]
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   374
        : answerRemovedTeams
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   375
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   376
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
   377
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
   378
    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
   379
    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
   380
        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
   381
        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
   382
                gameInfo = liftM (\g -> g{
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   383
                    teamsInGameNumber = teamsInGameNumber g - 1
8369
31033e521653 Throw away stupid Data.Seq
unc0rr
parents: 8247
diff changeset
   384
                    , roundMsgs = rmTeamMsg : roundMsgs g
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6733
diff changeset
   385
                }) $ 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
   386
            })
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
   387
        ]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   388
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
   389
    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
   390
    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
   391
    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
   392
    when (0 == teamsInGameNumber (fromJust gi)) $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   393
        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
   394
    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
   395
        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   396
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   397
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   398
processAction (RemoveTeam teamName) = do
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   399
    (Just ci) <- gets clientIndex
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   400
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   401
    ri <- clientRoomA
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   402
    inGame <- io $ do
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   403
        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
   404
        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
   405
        return $ r && c
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   406
    chans <- othersChans
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   407
    mapM_ processAction $
7126
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   408
        ModifyRoom (\r -> r{
8daa5c8e84c0 Bring leftTeams back (with a fix) as it is apparently needed for spectators.
unc0rr
parents: 7124
diff changeset
   409
            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
   410
            , 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
   411
            })
7947
0cf5277fef1a Better place for SendUpdateOnThisRoom
unc0rr
parents: 7945
diff changeset
   412
        : SendUpdateOnThisRoom
7124
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   413
        : AnswerClients chans ["REMOVE_TEAM", teamName]
cfee05712896 - Restore pre-r9257cf8e7af2 behavior
unc0rr
parents: 7120
diff changeset
   414
        : [SendTeamRemovalMessage teamName | inGame]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   415
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   416
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   417
processAction RemoveClientTeams = do
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   418
    (Just ci) <- gets clientIndex
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   419
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   420
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   421
    removeTeamActions <- io $ do
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   422
        rId <- clientRoomM rnc ci
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   423
        roomTeams <- room'sM rnc teams rId
8438
64ac58abd02a Don't resend "team quit" message when client closes engine, then quits room:
unc0rr
parents: 8422
diff changeset
   424
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamownerId t == ci) $ roomTeams
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   425
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   426
    mapM_ processAction removeTeamActions
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   427
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   428
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   429
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   430
processAction CheckRegistered = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   431
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   432
    n <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   433
    h <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   434
    p <- client's clientProto
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   435
    checker <- client's isChecker
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   436
    uid <- client's clUID
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   437
    -- allow multiple checker logins
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   438
    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
   439
    if (not checker) && haveSameNick then
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   440
        if p < 38 then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   441
            processAction $ ByeClient $ loc "Nickname is already in use"
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   442
            else
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   443
            processAction $ NoticeMessage NickAlreadyInUse
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   444
        else
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   445
        do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   446
        db <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   447
        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   448
        return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   449
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   450
processAction ClearAccountsCache = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   451
    dbq <- gets (dbQueries . serverInfo)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   452
    io $ writeChan dbq ClearCache
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   453
    return ()
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   454
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   455
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   456
processAction (ProcessAccountInfo info) = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   457
    case info of
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   458
        HasAccount passwd isAdmin -> do
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   459
            b <- isBanned
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   460
            c <- client's isChecker
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   461
            when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   462
        Guest -> do
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   463
            b <- isBanned
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   464
            when (not b) $
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   465
                processAction JoinLobby
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   466
        Admin -> do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   467
            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   468
            chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   469
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   470
    where
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   471
    isBanned = do
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   472
        processAction $ CheckBanned False
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8158
diff changeset
   473
        liftM B.null $ client's nick
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   474
    checkerLogin _ False = processAction $ ByeClient $ loc "No checker rights"
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   475
    checkerLogin p True = do
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   476
        wp <- client's webPassword
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   477
        processAction $
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   478
            if wp == p then ModifyClient $ \c -> c{logonPassed = True} else ByeClient $ loc "Authentication failed"
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   479
    playerLogin p a = do
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   480
        chan <- client's sendChan
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   481
        mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = p, isAdministrator = a})]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   482
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   483
processAction JoinLobby = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   484
    chan <- client's sendChan
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   485
    clientNick <- client's nick
7498
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   486
    isAuthenticated <- liftM (not . B.null) $ client's webPassword
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   487
    isAdmin <- client's isAdministrator
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   488
    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
   489
    let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   490
    let authenticatedNicks = L.map nick . L.filter (not . B.null . webPassword) $ loggedInClients
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   491
    let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   492
    let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin]]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   493
    mapM_ processAction . concat $ [
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   494
        [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   495
        , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   496
        , [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
   497
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   498
        , [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
   499
        , [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
   500
        , [SendServerMessage]
86984f6fa1b9 Introduce 'a' and 'u' client flags to mark admins and authenticated users
unc0rr
parents: 7465
diff changeset
   501
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   502
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   503
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   504
processAction (KickClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   505
    modify (\s -> s{clientIndex = Just kickId})
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   506
    clHost <- client's host
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   507
    currentTime <- io getCurrentTime
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   508
    mapM_ processAction [
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   509
        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
   510
        , ModifyClient (\c -> c{isKickedFromServer = True})
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   511
        , ByeClient "Kicked"
5214
d2ad737891b0 60 seconds cooldown ban on kick
unc0rr
parents: 5212
diff changeset
   512
        ]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   513
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   514
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   515
processAction (BanClient seconds reason banId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   516
    modify (\s -> s{clientIndex = Just banId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   517
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   518
    currentTime <- io getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   519
    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   520
    mapM_ processAction [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   521
        AddIP2Bans clHost msg (addUTCTime seconds currentTime)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   522
        , KickClient banId
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   523
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   524
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   525
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   526
processAction (BanIP ip seconds reason) = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   527
    currentTime <- io getCurrentTime
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   528
    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
   529
    processAction $
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   530
        AddIP2Bans ip msg (addUTCTime seconds currentTime)
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   531
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   532
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   533
processAction (BanNick n seconds reason) = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   534
    currentTime <- io getCurrentTime
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   535
    let msg = 
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   536
            if seconds > 60 * 60 * 24 * 365 then
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   537
                B.concat ["Permanent ban (", reason, ")"]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   538
                else
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   539
                B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   540
    processAction $
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   541
        AddNick2Bans n msg (addUTCTime seconds currentTime)
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7972
diff changeset
   542
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   543
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   544
processAction BanList = do
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   545
    time <- io $ getCurrentTime
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   546
    ch <- client's sendChan
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   547
    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
   548
    processAction $
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 7757
diff changeset
   549
        AnswerClients [ch] ["BANLIST", b]
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   550
    where
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   551
        ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time]
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   552
        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
   553
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   554
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   555
processAction (Unban entry) = do
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8155
diff changeset
   556
    processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s})
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   557
    where
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   558
        f (BanByIP bip _ _) = bip == entry
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7735
diff changeset
   559
        f (BanByNick bn _ _) = bn == entry
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   560
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 8241
diff changeset
   561
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   562
processAction (KickRoomClient kickId) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   563
    modify (\s -> s{clientIndex = Just kickId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   564
    ch <- client's sendChan
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   565
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]
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 (AddClient cl) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   569
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   570
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   571
    newClId <- io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   572
        ci <- addClient rnc cl
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   573
        _ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   574
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   575
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   576
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   577
        return ci
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   578
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   579
    modify (\s -> s{clientIndex = Just newClId})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   580
    mapM_ processAction
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   581
        [
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   582
            AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   583
            , CheckBanned True
6809
unc0rr
parents: 6805
diff changeset
   584
            , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   585
        ]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   586
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   587
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   588
processAction (AddNick2Bans n reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   589
    processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   590
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   591
processAction (AddIP2Bans ip reason expiring) = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   592
    (Just ci) <- gets clientIndex
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   593
    rc <- gets removedClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   594
    when (not $ ci `Set.member` rc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   595
        $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   596
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   597
processAction (CheckBanned byIP) = do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   598
    clTime <- client's connectTime
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   599
    clNick <- client's nick
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   600
    clHost <- client's host
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   601
    si <- gets serverInfo
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   602
    let validBans = filter (checkNotExpired clTime) $ bans si
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   603
    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
   604
    mapM_ processAction $
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   605
        ModifyServerInfo (\s -> s{bans = validBans})
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5214
diff changeset
   606
        : [ByeClient (getBanReason $ fromJust ban) | isJust ban]
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   607
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   608
        checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   609
        checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
8239
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   610
        checkBan True ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   611
        checkBan False _ n (BanByNick bn _ _) = caseInsensitiveCompare bn n
c9359078a2ed Better check for bans
unc0rr
parents: 8232
diff changeset
   612
        checkBan _ _ _ _ = False
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   613
        getBanReason (BanByIP _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   614
        getBanReason (BanByNick _ msg _) = msg
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   615
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   616
processAction PingAll = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   617
    rnc <- gets roomsClients
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   618
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   619
    cis <- io $ allClientsM rnc
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   620
    chans <- io $ mapM (client'sM rnc sendChan) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   621
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   622
    processAction $ AnswerClients chans ["PING"]
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   623
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   624
        kickTimeouted rnc ci = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   625
            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
   626
            when (pq > 0) $ do
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   627
                withStateT (\as -> as{clientIndex = Just ci}) $
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
   628
                    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
   629
--                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
   630
--                    processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   631
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   632
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   633
processAction StatsAction = do
5211
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   634
    si <- gets serverInfo
8ebf92014447 Don't send stats after spawning new server
unc0rr
parents: 5210
diff changeset
   635
    when (not $ shutdownPending si) $ do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   636
        rnc <- gets roomsClients
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   637
        (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   638
        io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   639
    where
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   640
          st irnc = (length $ allRooms irnc, length $ allClients irnc)
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   641
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7126
diff changeset
   642
processAction RestartServer = do
5212
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   643
    sp <- gets (shutdownPending . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   644
    when (not sp) $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   645
        sock <- gets (fromJust . serverSocket . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   646
        args <- gets (runArgs . serverInfo)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   647
        io $ do
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   648
            noticeM "Core" "Closing listening socket"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   649
            sClose sock
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   650
            noticeM "Core" "Spawning new server"
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   651
            _ <- createProcess (proc "./hedgewars-server" args)
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   652
            return ()
eaffb02f0053 Don't perform RestartServer action when already did it once
unc0rr
parents: 5211
diff changeset
   653
        processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   654
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   655
processAction Stats = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   656
    cls <- allClientsS
8452
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   657
    rms <- allRoomsS
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   658
    let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   659
    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
   660
    let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   661
    let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"])
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   662
            . concatMap (\p -> [
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   663
                    "<tr><td>", protoNumber2ver p
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   664
                    , "</td><td>", showB $ Map.findWithDefault 0 p clientsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   665
                    , "</td><td>", showB $ Map.findWithDefault 0 p roomsMap
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   666
                    , "</td></tr>"])
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   667
            . Set.toList $ keys
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   668
    processAction $ Warning versionsStats
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8439
diff changeset
   669
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   670
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   671
#if defined(OFFICIAL_SERVER)
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   672
processAction SaveReplay = do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   673
    ri <- clientRoomA
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   674
    rnc <- gets roomsClients
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8369
diff changeset
   675
5184
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   676
    io $ do
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   677
        r <- room'sM rnc id ri
bf7bba60ed93 update iphone too
nemo
parents: 5143
diff changeset
   678
        saveReplay r
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   679
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   680
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   681
processAction CheckRecord = do
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   682
    p <- client's clientProto
8482
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
   683
    c <- client's sendChan
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   684
    (cinfo, l) <- io $ loadReplay (fromIntegral p)
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   685
    when (not . null $ l) $
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   686
        mapM_ processAction [
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   687
            AnswerClients [c] ("REPLAY" : l)
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   688
            , ModifyClient $ \c -> c{checkInfo = cinfo}
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   689
            ]
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   690
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   691
processAction (CheckFailed msg) = do
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   692
    Just (CheckInfo fileName _) <- client's checkInfo
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   693
    io $ moveFailedRecord fileName
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   694
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   695
processAction (CheckSuccess info) = do
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   696
    Just (CheckInfo fileName _) <- client's checkInfo
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8507
diff changeset
   697
    io $ moveCheckedRecord fileName
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   698
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   699
#else
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   700
processAction SaveReplay = return ()
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8476
diff changeset
   701
processAction CheckRecord = return ()
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   702
processAction (CheckFailed _) = return ()
f4475782cf45 Some more work on checker
unc0rr
parents: 8482
diff changeset
   703
processAction (CheckSuccess _) = return ()
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   704
#endif