gameServer/Actions.hs
author unc0rr
Fri, 28 Jan 2011 22:19:06 +0300
branchserver_refactor
changeset 4604 831a4b91e9bc
parent 4601 08ae94dd4c0d
child 4606 4c521c4ab2b6
permissions -rw-r--r--
Reimplement some more Actions
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module Actions where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     4
import Control.Concurrent
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import qualified Data.IntSet as IntSet
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     7
import qualified Data.Set as Set
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
     8
import qualified Data.Sequence as Seq
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
     9
import System.Log.Logger
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    10
import Control.Monad
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
    11
import Data.Time
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    12
import Data.Maybe
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    13
import Control.Monad.Reader
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    14
import Control.Monad.State.Strict
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    15
import qualified Data.ByteString.Char8 as B
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    16
import Control.DeepSeq
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
import CoreTypes
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
    19
import Utils
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    20
import ClientIO
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    21
import ServerState
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
data Action =
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    24
    AnswerClients ![ClientChan] ![B.ByteString]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    25
    | SendServerMessage
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    26
    | SendServerVars
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    27
    | MoveToRoom RoomIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    28
    | MoveToLobby B.ByteString
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    29
    | RemoveTeam B.ByteString
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    30
    | RemoveRoom
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    31
    | UnreadyRoomClients
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    32
    | JoinLobby
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    33
    | ProtocolError B.ByteString
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    34
    | Warning B.ByteString
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    35
    | ByeClient B.ByteString
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    36
    | KickClient ClientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    37
    | KickRoomClient ClientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    38
    | BanClient B.ByteString -- nick
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    39
    | RemoveClientTeams ClientIndex
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    40
    | ModifyClient (ClientInfo -> ClientInfo)
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    41
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    42
    | ModifyRoom (RoomInfo -> RoomInfo)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    43
    | ModifyServerInfo (ServerInfo -> ServerInfo)
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    44
    | AddRoom B.ByteString B.ByteString
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    45
    | CheckRegistered
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    46
    | ClearAccountsCache
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    47
    | ProcessAccountInfo AccountInfo
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    48
    | AddClient ClientInfo
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    49
    | DeleteClient ClientIndex
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    50
    | PingAll
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    51
    | StatsAction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    53
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    55
instance NFData Action where
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    56
    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    57
    rnf a = a `seq` ()
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    58
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    59
instance NFData B.ByteString
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    60
instance NFData (Chan a)
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
    61
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    62
othersChans = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    63
    cl <- client's id
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    64
    ri <- clientRoomA
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    65
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    66
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    67
processAction :: Action -> StateT ServerState IO ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    70
processAction (AnswerClients chans msg) = do
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
    71
    io $ mapM_ (flip writeChan msg) chans
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    74
processAction SendServerMessage = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    75
    chan <- client's sendChan
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    76
    protonum <- client's clientProto
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    77
    si <- liftM serverInfo get
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    78
    let message = if protonum < latestReleaseVersion si then
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    79
            serverMessageForOldVersions si
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    80
            else
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    81
            serverMessage si
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    82
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    83
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    84
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    85
processAction SendServerVars = do
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    86
    chan <- client's sendChan
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    87
    si <- gets serverInfo
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    88
    io $ writeChan chan ("SERVER_VARS" : vars si)
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    89
    where
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    90
        vars si = [
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    91
            "MOTD_NEW", serverMessage si,
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    92
            "MOTD_OLD", serverMessageForOldVersions si,
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    93
            "LATEST_PROTO", B.pack . show $ latestReleaseVersion si
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    94
            ]
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    95
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    96
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    97
processAction (ProtocolError msg) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    98
    chan <- client's sendChan
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    99
    processAction $ AnswerClients [chan] ["ERROR", msg]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   100
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   102
processAction (Warning msg) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   103
    chan <- client's sendChan
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   104
    processAction $ AnswerClients [chan] ["WARNING", msg]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   105
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   106
processAction (ByeClient msg) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   107
    (Just ci) <- gets clientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   108
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   109
    ri <- clientRoomA
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   110
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   111
    chan <- client's sendChan
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   112
    clNick <- client's nick
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3452
diff changeset
   113
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   114
    when (ri /= lobbyId) $ do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   115
        processAction $ MoveToLobby ("quit: " `B.append` msg)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   116
        return ()
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   117
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   118
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   119
    io $ do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   120
        infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   121
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   122
    processAction $ AnswerClients [chan] ["BYE", msg]
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   123
    processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   124
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   125
    s <- get
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   126
    put $! s{removedClients = ci `Set.insert` removedClients s}
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   127
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   128
processAction (DeleteClient ci) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   129
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   130
    io $ removeClient rnc ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   131
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   132
    s <- get
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   133
    put $! s{removedClients = ci `Set.delete` removedClients s}
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   134
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   135
processAction (ModifyClient f) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   136
    (Just ci) <- gets clientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   137
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   138
    io $ modifyClient rnc f ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   139
    return ()
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   140
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   141
processAction (ModifyClient2 ci f) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   142
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   143
    io $ modifyClient rnc f ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   144
    return ()
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   145
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   146
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   147
processAction (ModifyRoom f) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   148
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   149
    ri <- clientRoomA
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   150
    io $ modifyRoom rnc f ri
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   151
    return ()
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2352
diff changeset
   152
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   153
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   154
processAction (ModifyServerInfo f) =
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   155
    modify (\s -> s{serverInfo = f $ serverInfo s})
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   156
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
   157
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   158
processAction (MoveToRoom ri) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   159
    (Just ci) <- gets clientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   160
    rnc <- gets roomsClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
   161
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   162
    io $ do
4573
7e3be7d7eeda Fix typo
unc0rr
parents: 4571
diff changeset
   163
        modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   164
        modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
   165
        moveClientToRoom rnc ri ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   166
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   167
    chans <- liftM (map sendChan) $ roomClientsS ri
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   168
    clNick <- client's nick
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3568
diff changeset
   169
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   170
    processAction $ AnswerClients chans ["JOINED", clNick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   171
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4585
diff changeset
   172
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   173
processAction (MoveToLobby msg) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   174
    (Just ci) <- gets clientIndex
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   175
    ri <- clientRoomA
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   176
    rnc <- gets roomsClients
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   177
    room <- clientRoomA
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   178
    ready <- client's isReady
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   179
    master <- client's isMaster
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   180
    client <- client's id
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   181
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   182
    if master then
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   183
        processAction RemoveRoom
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   184
        else
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   185
        do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   186
        clNick <- client's nick
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   187
        clChan <- client's sendChan
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   188
        chans <- othersChans
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   189
        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   190
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   191
    io $ do
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   192
            modifyRoom rnc (\r -> r{
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   193
                    playersIn = (playersIn r) - 1,
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   194
                    readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   195
                    }) ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   196
            moveClientToLobby rnc ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   197
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   198
{-
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   199
    (_, _, newClients, newRooms) <-
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   200
            if isMaster client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   201
                if (gameinprogress room) && (playersIn room > 1) then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   202
                    (changeMaster >>= (\state -> foldM processAction state
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   203
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   204
                        AnswerOthersInRoom ["WARNING", "Admin left the room"],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   205
                        RemoveClientTeams clID]))
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   206
                else -- not in game
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   207
                    processAction (clID, serverInfo, rnc) RemoveRoom
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   208
            else -- not master
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   209
                foldM
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   210
                    processAction
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   211
                        (clID, serverInfo, rnc)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   212
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   213
                        RemoveClientTeams clID]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   214
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   215
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   216
    return (
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   217
        clID,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   218
        serverInfo,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   219
        adjust resetClientFlags clID newClients,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   220
        adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   221
        )
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   222
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   223
        rID = roomID client
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   224
        client = clients ! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   225
        room = rooms ! rID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   226
        resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   227
        removeClientFromRoom r = r{
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   228
                playersIDs = otherPlayersSet,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   229
                playersIn = (playersIn r) - 1,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   230
                readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   231
                }
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   232
        insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   233
        changeMaster = do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   234
            processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   235
            return (
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   236
                clID,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   237
                serverInfo,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   238
                adjust (\cl -> cl{isMaster = True}) newMasterId clients,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   239
                adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   240
                )
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   241
        newRoomName = nick newMasterClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   242
        otherPlayersSet = IntSet.delete clID (playersIDs room)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   243
        newMasterId = IntSet.findMin otherPlayersSet
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   244
        newMasterClient = clients ! newMasterId
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   245
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   246
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   247
processAction (AddRoom roomName roomPassword) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   248
    Just clId <- gets clientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   249
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   250
    proto <- io $ client'sM rnc clientProto clId
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   251
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   252
    let room = newRoom{
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   253
            masterID = clId,
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   254
            name = roomName,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   255
            password = roomPassword,
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   256
            roomProto = proto
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   257
            }
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3568
diff changeset
   258
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   259
    rId <- io $ addRoom rnc room
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   260
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   261
    processAction $ MoveToRoom rId
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   262
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   263
    chans <- liftM (map sendChan) $! roomClientsS lobbyId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   264
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   265
    mapM_ processAction [
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   266
        AnswerClients chans ["ROOM", "ADD", roomName]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   267
        , ModifyClient (\cl -> cl{isMaster = True})
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   268
        ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   269
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   270
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   271
processAction RemoveRoom = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   272
    Just clId <- gets clientIndex
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   273
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   274
    ri <- io $ clientRoomM rnc clId
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   275
    roomName <- io $ room'sM rnc name ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   276
    others <- othersChans
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   277
    lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   278
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   279
    mapM_ processAction [
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   280
            AnswerClients lobbyChans ["ROOM", "DEL", roomName],
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   281
            AnswerClients others ["ROOMABANDONED", roomName]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   282
        ]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   283
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   284
    io $ removeRoom rnc ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   285
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   286
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   287
processAction (UnreadyRoomClients) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   288
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   289
    ri <- clientRoomA
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   290
    roomPlayers <- roomClientsS ri
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   291
    roomClIDs <- io $ roomClientsIndicesM rnc ri
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   292
    processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   293
    io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   294
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   295
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   296
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   297
processAction (RemoveTeam teamName) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   298
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   299
    cl <- client's id
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   300
    ri <- clientRoomA
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   301
    inGame <- io $ room'sM rnc gameinprogress ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   302
    chans <- othersChans
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   303
    if inGame then
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   304
            mapM_ processAction [
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   305
                AnswerClients chans ["REMOVE_TEAM", teamName],
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   306
                ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   307
                ]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   308
        else
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   309
            mapM_ processAction [
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   310
                AnswerClients chans ["EM", rmTeamMsg],
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   311
                ModifyRoom (\r -> r{
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   312
                    teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   313
                    leftTeams = teamName : leftTeams r,
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   314
                    roundMsgs = roundMsgs r Seq.|> rmTeamMsg
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   315
                    })
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   316
                ]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   317
    where
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   318
        rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   319
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   320
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   321
processAction (RemoveClientTeams clId) = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   322
    rnc <- gets roomsClients
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   323
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   324
    removeTeamActions <- io $ do
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   325
        clNick <- client'sM rnc nick clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   326
        rId <- clientRoomM rnc clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   327
        roomTeams <- room'sM rnc teams rId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   328
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   329
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   330
    mapM_ processAction removeTeamActions
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   331
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   332
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   333
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   334
processAction CheckRegistered = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   335
    (Just ci) <- gets clientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   336
    n <- client's nick
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   337
    h <- client's host
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   338
    db <- gets (dbQueries . serverInfo)
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   339
    io $ writeChan db $ CheckAccount ci n h
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   340
    return ()
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   341
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   342
4599
a9e4093a7e78 Reimplement one more Action
unc0rr
parents: 4597
diff changeset
   343
processAction ClearAccountsCache = do
a9e4093a7e78 Reimplement one more Action
unc0rr
parents: 4597
diff changeset
   344
    dbq <- gets (dbQueries . serverInfo)
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   345
    io $ writeChan dbq ClearCache
4599
a9e4093a7e78 Reimplement one more Action
unc0rr
parents: 4597
diff changeset
   346
    return ()
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   347
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
   348
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   349
processAction (ProcessAccountInfo info) =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   350
    case info of
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   351
        HasAccount passwd isAdmin -> do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   352
            chan <- client's sendChan
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   353
            processAction $ AnswerClients [chan] ["ASKPASSWORD"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   354
        Guest -> do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   355
            processAction JoinLobby
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   356
        Admin -> do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   357
            mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   358
            chan <- client's sendChan
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   359
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   360
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   361
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   362
processAction JoinLobby = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   363
    chan <- client's sendChan
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   364
    clientNick <- client's nick
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   365
    (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   366
    mapM_ processAction $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   367
        (AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   368
        : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   369
        ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
2118
0ebcc98ebc1a Send server message after nicks info (more chance for it to be seen)
unc0rr
parents: 2116
diff changeset
   370
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   371
{-
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   372
processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   373
    processAction (
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   374
        clID,
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   375
        serverInfo,
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   376
        adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   377
        adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   378
            adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   379
        ) joinMsg
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   380
    where
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   381
        client = clients ! clID
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   382
        joinMsg = if rID == 0 then
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   383
                AnswerAllOthers ["LOBBY:JOINED", nick client]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   384
            else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   385
                AnswerThisRoom ["JOINED", nick client]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   386
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   387
processAction (clID, serverInfo, rnc) (KickClient kickID) =
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   388
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   389
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   390
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   391
processAction (clID, serverInfo, rnc) (BanClient banNick) =
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   392
    return (clID, serverInfo, rnc)
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   393
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   394
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   395
processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   396
    writeChan (sendChan $ clients ! kickID) ["KICKED"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   397
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   398
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   399
-}
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   400
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   401
processAction (AddClient client) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   402
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   403
    si <- gets serverInfo
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   404
    io $ do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   405
        ci <- addClient rnc client
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4573
diff changeset
   406
        t <- forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
   407
        forkIO $ clientSendLoop (clientSocket client) t (coreChan si) (sendChan client) ci
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
   408
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   409
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   410
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   411
    processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   412
{-        let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   413
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   414
        if False && (isJust $ host client `Prelude.lookup` newLogins) then
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   415
            processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   416
            else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   417
            return (ci, serverInfo)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   418
-}
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   419
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
   420
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   421
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   422
processAction PingAll = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   423
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   424
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   425
    cis <- io $ allClientsM rnc
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   426
    chans <- io $ mapM (client'sM rnc sendChan) cis
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   427
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   428
    processAction $ AnswerClients chans ["PING"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   429
    where
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   430
        kickTimeouted rnc ci = do
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   431
            pq <- io $ client'sM rnc pingsQueue ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   432
            when (pq > 0) $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   433
                withStateT (\as -> as{clientIndex = Just ci}) $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   434
                    processAction (ByeClient "Ping timeout")
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   435
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   436
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   437
processAction (StatsAction) = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   438
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   439
    si <- gets serverInfo
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   440
    (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   441
    io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   442
    where
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   443
          stats irnc = (length $ allRooms irnc, length $ allClients irnc)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   444