gameServer/Actions.hs
author unc0rr
Wed, 26 Jan 2011 22:04:18 +0300
branchserver_refactor
changeset 4591 c91364bf6a69
parent 4587 adf64662b6a8
child 4597 31e042ab870c
permissions -rw-r--r--
Send teams info on join
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
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
import CoreTypes
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
    18
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
    19
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
    20
import ServerState
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
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
    23
    AnswerClients ![ClientChan] ![B.ByteString]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    24
    | SendServerMessage
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    25
    | 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
    26
    | 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
    27
    | 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
    28
    | RemoveTeam B.ByteString
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    29
    | RemoveRoom
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    30
    | 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
    31
    | 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
    32
    | 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
    33
    | 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
    34
    | 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
    35
    | 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
    36
    | 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
    37
    | 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
    38
    | RemoveClientTeams ClientIndex
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    39
    | 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
    40
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    41
    | ModifyRoom (RoomInfo -> RoomInfo)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    42
    | 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
    43
    | AddRoom B.ByteString B.ByteString
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    44
    | CheckRegistered
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    45
    | ClearAccountsCache
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    46
    | ProcessAccountInfo AccountInfo
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    47
    | Dump
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
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
    55
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    56
othersChans = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    57
    cl <- client's id
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    58
    ri <- clientRoomA
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    59
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
    60
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
    61
processAction :: Action -> StateT ServerState IO ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
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
    64
processAction (AnswerClients chans 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
    65
    liftIO $ map (flip seq ()) chans `seq` map (flip seq ()) msg `seq` mapM_ (flip writeChan msg) chans
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
4e78ad846fb6 New game server:
unc0rr
parents:
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 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
    69
    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
    70
    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
    71
    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
    72
    let message = if protonum < latestReleaseVersion si then
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    73
            serverMessageForOldVersions si
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
    74
            else
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    75
            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
    76
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
1f5604cd99be This revision should, in 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
{-
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    78
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
    79
processAction (clID, serverInfo, rnc) SendServerVars = do
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    80
    writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
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
    81
    return (clID, serverInfo, rnc)
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    82
    where
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    83
        client = clients ! clID
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    84
        vars = [
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
    85
            "MOTD_NEW", serverMessage 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
    86
            "MOTD_OLD", serverMessageForOldVersions serverInfo,
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    87
            "LATEST_PROTO", show $ latestReleaseVersion serverInfo
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 2948
diff changeset
    88
            ]
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    89
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    90
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
    91
-}
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    92
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
    93
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
    94
    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
    95
    processAction $ AnswerClients [chan] ["ERROR", msg]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
4e78ad846fb6 New game server:
unc0rr
parents:
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 (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
    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] ["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
   101
1f5604cd99be This revision should, in 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 (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
   103
    (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
   104
    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
   105
    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
   106
1f5604cd99be This revision should, in 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
    chan <- client's sendChan
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3452
diff changeset
   108
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
   109
    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
   110
        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
   111
        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
   112
1f5604cd99be This revision should, in 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
    liftIO $ 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
   114
        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
   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
        --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   118
    processAction $ AnswerClients [chan] ["BYE", 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
   119
1f5604cd99be This revision should, in 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
    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
   121
    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
   122
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   123
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
   124
    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
   125
    liftIO $ removeClient rnc 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
   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
    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
   128
    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
   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
{-
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   131
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   132
        client = clients ! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   133
        clientNick = nick client
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   134
        answerInformRoom =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   135
            if roomID client /= 0 then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   136
                if not $ Prelude.null msg then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   137
                    [AnswerThisRoom ["LEFT", clientNick, msg]]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   138
                else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   139
                    [AnswerThisRoom ["LEFT", clientNick]]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   140
            else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   141
                []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   142
        answerOthersQuit =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   143
            if logonPassed client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   144
                if not $ Prelude.null msg then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   145
                    [AnswerAll ["LOBBY:LEFT", clientNick, msg]]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   146
                else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   147
                    [AnswerAll ["LOBBY:LEFT", clientNick]]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   148
            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
   149
            [] 
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
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 (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
   153
    (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
   154
    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
   155
    liftIO $ modifyClient rnc f 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
   156
    return ()
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
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 (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
   159
    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
   160
    liftIO $ modifyClient rnc f 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
   161
    return ()
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   162
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   163
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
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
   165
    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
   166
    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
   167
    liftIO $ modifyRoom rnc f 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
    return ()
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2352
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
{-
1f5604cd99be This revision should, in 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
processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
1f5604cd99be This revision should, in 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
    return (clID, func serverInfo, rnc)
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in 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
-}
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
   176
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
   177
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
   178
    (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
   179
    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
   180
    liftIO $ do
4573
7e3be7d7eeda Fix typo
unc0rr
parents: 4571
diff changeset
   181
        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
   182
        modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) 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
   183
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   184
    liftIO $ moveClientToRoom rnc ri 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
   185
1f5604cd99be This revision should, in 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
    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
   187
    clNick <- client's nick
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3568
diff changeset
   188
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
   189
    processAction $ AnswerClients chans ["JOINED", clNick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   190
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4585
diff changeset
   191
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
   192
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
   193
    (Just ci) <- gets clientIndex
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   194
    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
   195
    rnc <- gets roomsClients
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   196
    room <- clientRoomA
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   197
    ready <- client's isReady
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   198
    master <- client's isMaster
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   199
    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
   200
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   201
    if master then
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   202
        processAction RemoveRoom
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   203
        else
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   204
        do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   205
        clNick <- client's nick
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   206
        clChan <- client's sendChan
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   207
        chans <- othersChans
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   208
        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   209
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   210
    liftIO $ do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   211
            modifyRoom rnc (\r -> r{
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   212
                    playersIn = (playersIn r) - 1,
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   213
                    readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   214
                    }) ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   215
            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
   216
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   217
{-
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   218
    (_, _, newClients, newRooms) <-
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   219
            if isMaster client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   220
                if (gameinprogress room) && (playersIn room > 1) then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   221
                    (changeMaster >>= (\state -> foldM processAction state
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   222
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   223
                        AnswerOthersInRoom ["WARNING", "Admin left the room"],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   224
                        RemoveClientTeams clID]))
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   225
                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
   226
                    processAction (clID, serverInfo, rnc) RemoveRoom
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   227
            else -- not master
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   228
                foldM
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   229
                    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
   230
                        (clID, serverInfo, rnc)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   231
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   232
                        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
   233
1f5604cd99be This revision should, in 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
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 resetClientFlags clID newClients,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   239
        adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
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
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   242
        rID = roomID client
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   243
        client = clients ! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   244
        room = rooms ! rID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   245
        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
   246
        removeClientFromRoom r = r{
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   247
                playersIDs = otherPlayersSet,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   248
                playersIn = (playersIn r) - 1,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   249
                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
   250
                }
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   251
        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
   252
        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
   253
            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
   254
            return (
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   255
                clID,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   256
                serverInfo,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   257
                adjust (\cl -> cl{isMaster = True}) newMasterId clients,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   258
                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
   259
                )
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   260
        newRoomName = nick newMasterClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   261
        otherPlayersSet = IntSet.delete clID (playersIDs room)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   262
        newMasterId = IntSet.findMin otherPlayersSet
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   263
        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
   264
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   265
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
   266
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
   267
    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
   268
    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
   269
    proto <- liftIO $ client'sM rnc clientProto 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
   270
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   271
    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
   272
            masterID = clId,
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   273
            name = roomName,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   274
            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
   275
            roomProto = proto
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   276
            }
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3568
diff changeset
   277
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
   278
    rId <- liftIO $ addRoom rnc room
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   279
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   280
    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
   281
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   282
    chans <- liftM (map sendChan) $! roomClientsS lobbyId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   283
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
   284
    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
   285
        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
   286
        , 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
   287
        ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   288
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   289
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   290
processAction RemoveRoom = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   291
    Just clId <- gets clientIndex
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   292
    rnc <- gets roomsClients
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   293
    ri <- liftIO $ clientRoomM rnc clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   294
    roomName <- liftIO $ room'sM rnc name ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   295
    others <- othersChans
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   296
    lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   297
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   298
    mapM_ processAction [
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   299
            AnswerClients lobbyChans ["ROOM", "DEL", roomName],
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   300
            AnswerClients others ["ROOMABANDONED", roomName]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   301
        ]
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   302
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   303
    liftIO $ removeRoom rnc ri
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   304
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   305
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
   306
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
   307
    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
   308
    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
   309
    roomPlayers <- 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
   310
    roomClIDs <- liftIO $ roomClientsIndicesM rnc 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
   311
    processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
1f5604cd99be This revision should, in 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
    liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
1f5604cd99be This revision should, in 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
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   314
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   315
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
   316
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
   317
    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
   318
    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
   319
    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
   320
    inGame <- liftIO $ room'sM rnc gameinprogress ri
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   321
    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
   322
    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
   323
            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
   324
                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
   325
                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
   326
                ]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   327
        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
   328
            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
   329
                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
   330
                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
   331
                    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
   332
                    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
   333
                    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
   334
                    })
1f5604cd99be This revision should, in 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
                ]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   336
    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
   337
        rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   338
4571
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   339
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   340
processAction (RemoveClientTeams clId) = do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   341
    rnc <- gets roomsClients
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   342
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   343
    removeTeamActions <- liftIO $ do
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   344
        clNick <- client'sM rnc nick clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   345
        rId <- clientRoomM rnc clId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   346
        roomTeams <- room'sM rnc teams rId
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   347
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   348
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   349
    mapM_ processAction removeTeamActions
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   350
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   351
597440c80b8a Bring back room and teams removing
unc0rr
parents: 4337
diff changeset
   352
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
   353
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
   354
    (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
   355
    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
   356
    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
   357
    db <- gets (dbQueries . 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
   358
    liftIO $ writeChan db $ CheckAccount ci n h
1f5604cd99be This revision should, in 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
    return ()
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   360
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
   361
{-
1f5604cd99be This revision should, in 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 (clID, serverInfo, rnc) (ClearAccountsCache) = 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
    writeChan (dbQueries serverInfo) ClearCache
1f5604cd99be This revision should, in 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
    return (clID, serverInfo, rnc)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   365
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   366
        client = clients ! clID
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   367
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   368
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
   369
processAction (clID, serverInfo, rnc) (Dump) = 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
   370
    writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree 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
   371
    return (clID, serverInfo, rnc)
1f5604cd99be This revision should, in 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
-}
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
   373
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
   374
processAction (ProcessAccountInfo info) =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   375
    case info of
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   376
        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
   377
            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
   378
            processAction $ AnswerClients [chan] ["ASKPASSWORD"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   379
        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
   380
            processAction JoinLobby
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   381
        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
   382
            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
   383
            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
   384
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   385
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   386
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
   387
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
   388
    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
   389
    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
   390
    (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
   391
    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
   392
        (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
   393
        : [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
   394
        ++ [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
   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
{-
1f5604cd99be This revision should, in 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
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
   398
    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
   399
        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
   400
        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
   401
        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
   402
        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
   403
            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
   404
        ) joinMsg
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   405
    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
   406
        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
   407
        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
   408
                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
   409
            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
   410
                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
   411
1f5604cd99be This revision should, in 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
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
   413
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   414
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   415
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
   416
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
   417
    return (clID, serverInfo, rnc)
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   418
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   419
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
   420
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
   421
    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
   422
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   423
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
   424
-}
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   425
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
   426
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
   427
    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
   428
    si <- gets 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
   429
    liftIO $ 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
   430
        ci <- addClient rnc client
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4573
diff changeset
   431
        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
   432
        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
   433
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
   434
        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
   435
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   436
    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
   437
{-        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
   438
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
   439
        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
   440
            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
   441
            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
   442
            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
   443
-}
1f5604cd99be This revision should, in 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
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3436
diff changeset
   445
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   446
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
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
   448
    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
   449
    liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   450
    cis <- liftIO $ allClientsM rnc
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   451
    chans <- liftIO $ mapM (client'sM rnc sendChan) cis
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   452
    liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   453
    processAction $ AnswerClients chans ["PING"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2662
diff changeset
   454
    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
   455
        kickTimeouted rnc 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
   456
            pq <- liftIO $ client'sM rnc pingsQueue 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
   457
            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
   458
                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
   459
                    processAction (ByeClient "Ping timeout")
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   460
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   461
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
   462
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
   463
    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
   464
    si <- gets 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
   465
    (roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   466
    liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   467
    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
   468
          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
   469