gameServer/Actions.hs
author unc0rr
Sat, 29 Jan 2011 21:33:24 +0300
branchserver_refactor
changeset 4612 e82758d6f924
parent 4610 9541b2a76067
child 4622 8bdc879ee6b2
permissions -rw-r--r--
- Reactivate pings timer, reimplement PING handler - Reimplement INFO
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
4610
9541b2a76067 Introduce numbered server notice messages
unc0rr
parents: 4606
diff changeset
    35
    | NoticeMessage Notice
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
    36
    | 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
    37
    | 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
    38
    | 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
    39
    | 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
    40
    | RemoveClientTeams ClientIndex
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    41
    | 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
    42
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    43
    | ModifyRoom (RoomInfo -> RoomInfo)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    44
    | 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
    45
    | AddRoom B.ByteString B.ByteString
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    46
    | CheckRegistered
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    47
    | ClearAccountsCache
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    48
    | ProcessAccountInfo AccountInfo
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    49
    | 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
    50
    | DeleteClient ClientIndex
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    51
    | PingAll
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    52
    | StatsAction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
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
    54
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    56
instance NFData Action where
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    57
    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
    58
    rnf a = a `seq` ()
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    59
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    60
instance NFData B.ByteString
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
    61
instance NFData (Chan a)
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
    62
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    63
othersChans = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    64
    cl <- client's id
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    65
    ri <- clientRoomA
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    66
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    67
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
    68
processAction :: Action -> StateT ServerState IO ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
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
    71
processAction (AnswerClients chans msg) = do
4606
4c521c4ab2b6 Force RNF in AnswerClients too, in order to prevent lazyness in actions (most probably it's redundant to do that, still I do)
unc0rr
parents: 4604
diff changeset
    72
    io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
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
    75
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
    76
    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
    77
    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
    78
    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
    79
    let message = if protonum < latestReleaseVersion si then
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    80
            serverMessageForOldVersions si
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    81
            else
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    82
            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
    83
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    84
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    85
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    86
processAction SendServerVars = do
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    87
    chan <- client's sendChan
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    88
    si <- gets serverInfo
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    89
    io $ writeChan chan ("SERVER_VARS" : vars si)
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    90
    where
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    91
        vars si = [
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    92
            "MOTD_NEW", serverMessage si,
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    93
            "MOTD_OLD", serverMessageForOldVersions si,
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
    94
            "LATEST_PROTO", B.pack . show $ latestReleaseVersion si
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    95
            ]
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    96
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    97
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
    98
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
    99
    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
   100
    processAction $ AnswerClients [chan] ["ERROR", msg]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   102
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
   103
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
   104
    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
   105
    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
   106
4610
9541b2a76067 Introduce numbered server notice messages
unc0rr
parents: 4606
diff changeset
   107
processAction (NoticeMessage n) = do
9541b2a76067 Introduce numbered server notice messages
unc0rr
parents: 4606
diff changeset
   108
    chan <- client's sendChan
9541b2a76067 Introduce numbered server notice messages
unc0rr
parents: 4606
diff changeset
   109
    processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
9541b2a76067 Introduce numbered server notice messages
unc0rr
parents: 4606
diff changeset
   110
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
   111
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
   112
    (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
   113
    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
   114
    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
   115
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
    chan <- client's sendChan
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   117
    clNick <- client's nick
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3452
diff changeset
   118
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
   119
    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
   120
        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
   121
        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
   122
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   123
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   124
    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
   125
        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
   126
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
    processAction $ AnswerClients [chan] ["BYE", msg]
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   128
    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
   129
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
   130
    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
   131
    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
   132
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
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
   134
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   135
    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
   136
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
    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
   138
    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
   139
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
   140
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
   141
    (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
   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
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
   146
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
   147
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   148
    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
   149
    return ()
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   150
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   151
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
   152
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
   153
    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
   154
    ri <- clientRoomA
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   155
    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
   156
    return ()
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2352
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
4604
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   159
processAction (ModifyServerInfo f) =
831a4b91e9bc Reimplement some more Actions
unc0rr
parents: 4601
diff changeset
   160
    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
   161
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
   162
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
   163
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
   164
    (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
   165
    rnc <- gets roomsClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4587
diff changeset
   166
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   167
    io $ do
4573
7e3be7d7eeda Fix typo
unc0rr
parents: 4571
diff changeset
   168
        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
   169
        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
   170
        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
   171
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
   172
    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
   173
    clNick <- client's nick
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3568
diff changeset
   174
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
   175
    processAction $ AnswerClients chans ["JOINED", clNick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   176
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4585
diff changeset
   177
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
   178
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
   179
    (Just ci) <- gets clientIndex
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   180
    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
   181
    rnc <- gets roomsClients
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   182
    room <- clientRoomA
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   183
    ready <- client's isReady
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   184
    master <- client's isMaster
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   185
    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
   186
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   187
    if master then
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   188
        processAction RemoveRoom
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   189
        else
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   190
        do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   191
        clNick <- client's nick
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   192
        clChan <- client's sendChan
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   193
        chans <- othersChans
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   194
        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   195
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   196
    io $ do
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   197
            modifyRoom rnc (\r -> r{
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   198
                    playersIn = (playersIn r) - 1,
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   199
                    readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   200
                    }) ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   201
            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
   202
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
   203
{-
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   204
    (_, _, newClients, newRooms) <-
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   205
            if isMaster client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   206
                if (gameinprogress room) && (playersIn room > 1) then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   207
                    (changeMaster >>= (\state -> foldM processAction state
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   208
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   209
                        AnswerOthersInRoom ["WARNING", "Admin left the room"],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   210
                        RemoveClientTeams clID]))
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   211
                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
   212
                    processAction (clID, serverInfo, rnc) RemoveRoom
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   213
            else -- not master
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   214
                foldM
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   215
                    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
   216
                        (clID, serverInfo, rnc)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   217
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   218
                        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
   219
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
   220
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   221
    return (
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   222
        clID,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   223
        serverInfo,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   224
        adjust resetClientFlags clID newClients,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   225
        adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   226
        )
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   227
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   228
        rID = roomID client
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   229
        client = clients ! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   230
        room = rooms ! rID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   231
        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
   232
        removeClientFromRoom r = r{
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   233
                playersIDs = otherPlayersSet,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   234
                playersIn = (playersIn r) - 1,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   235
                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
   236
                }
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   237
        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
   238
        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
   239
            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
   240
            return (
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   241
                clID,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   242
                serverInfo,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   243
                adjust (\cl -> cl{isMaster = True}) newMasterId clients,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   244
                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
   245
                )
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   246
        newRoomName = nick newMasterClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   247
        otherPlayersSet = IntSet.delete clID (playersIDs room)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   248
        newMasterId = IntSet.findMin otherPlayersSet
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   249
        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
   250
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   251
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
   252
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
   253
    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
   254
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   255
    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
   256
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   257
    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
   258
            masterID = clId,
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   259
            name = roomName,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   260
            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
   261
            roomProto = proto
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   262
            }
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3568
diff changeset
   263
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   264
    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
   265
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
    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
   267
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
    chans <- liftM (map sendChan) $! roomClientsS lobbyId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   269
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
   270
    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
   271
        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
   272
        , 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
   273
        ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   274
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   275
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   276
processAction RemoveRoom = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   277
    Just clId <- gets clientIndex
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   278
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   279
    ri <- io $ clientRoomM rnc clId
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   280
    roomName <- io $ room'sM rnc name ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   281
    others <- othersChans
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   282
    lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   283
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   284
    mapM_ processAction [
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   285
            AnswerClients lobbyChans ["ROOM", "DEL", roomName],
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   286
            AnswerClients others ["ROOMABANDONED", roomName]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   287
        ]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   288
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   289
    io $ removeRoom rnc ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   290
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   291
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 (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
   293
    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
   294
    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
   295
    roomPlayers <- roomClientsS ri
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   296
    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
   297
    processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   298
    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
   299
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   300
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   301
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
   302
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
   303
    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
   304
    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
   305
    ri <- clientRoomA
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   306
    inGame <- io $ room'sM rnc gameinprogress ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   307
    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
   308
    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
   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 ["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
   311
                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
   312
                ]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   313
        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
   314
            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
   315
                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
   316
                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
   317
                    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
   318
                    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
   319
                    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
   320
                    })
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
   321
                ]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   322
    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
   323
        rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   324
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   325
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   326
processAction (RemoveClientTeams clId) = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   327
    rnc <- gets roomsClients
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   328
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   329
    removeTeamActions <- io $ do
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   330
        clNick <- client'sM rnc nick clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   331
        rId <- clientRoomM rnc clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   332
        roomTeams <- room'sM rnc teams rId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   333
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   334
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   335
    mapM_ processAction removeTeamActions
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   336
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   337
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   338
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
   339
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
   340
    (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
   341
    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
   342
    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
   343
    db <- gets (dbQueries . serverInfo)
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   344
    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
   345
    return ()
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   346
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   347
4599
a9e4093a7e78 Reimplement one more Action
unc0rr
parents: 4597
diff changeset
   348
processAction ClearAccountsCache = do
a9e4093a7e78 Reimplement one more Action
unc0rr
parents: 4597
diff changeset
   349
    dbq <- gets (dbQueries . serverInfo)
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   350
    io $ writeChan dbq ClearCache
4599
a9e4093a7e78 Reimplement one more Action
unc0rr
parents: 4597
diff changeset
   351
    return ()
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   352
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
   353
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
   354
processAction (ProcessAccountInfo info) =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   355
    case info of
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   356
        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
   357
            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
   358
            processAction $ AnswerClients [chan] ["ASKPASSWORD"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   359
        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
   360
            processAction JoinLobby
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   361
        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
   362
            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
   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
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   365
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   366
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
   367
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
   368
    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
   369
    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
   370
    (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
   371
    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
   372
        (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
   373
        : [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
   374
        ++ [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
   375
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
   376
{-
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
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
   378
    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
   379
        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
   380
        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
   381
        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
   382
        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
   383
            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
   384
        ) joinMsg
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   385
    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
   386
        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
   387
        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
   388
                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
   389
            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
   390
                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
   391
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
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
   393
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   394
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   395
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
   396
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
   397
    return (clID, serverInfo, rnc)
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   398
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   399
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
   400
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
   401
    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
   402
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   403
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
   404
-}
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   405
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
   406
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
   407
    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
   408
    si <- gets serverInfo
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   409
    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
   410
        ci <- addClient rnc client
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4573
diff changeset
   411
        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
   412
        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
   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
        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
   415
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
    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
   417
{-        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
   418
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
   419
        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
   420
            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
   421
            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
   422
            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
   423
-}
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
   424
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
   425
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   426
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
   427
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
   428
    rnc <- gets roomsClients
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   429
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   430
    cis <- io $ allClientsM rnc
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   431
    chans <- io $ mapM (client'sM rnc sendChan) cis
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   432
    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
   433
    processAction $ AnswerClients chans ["PING"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   434
    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
   435
        kickTimeouted rnc ci = do
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   436
            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
   437
            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
   438
                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
   439
                    processAction (ByeClient "Ping timeout")
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   440
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   441
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
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
   443
    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
   444
    si <- gets serverInfo
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   445
    (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats
08ae94dd4c0d io = liftIO
unc0rr
parents: 4599
diff changeset
   446
    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
   447
    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
   448
          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
   449