gameServer/HWProtoInRoomState.hs
author szczur
Sun, 12 Sep 2010 17:38:14 -0400
changeset 3850 df6ecca1894f
parent 3655 1ae653467897
child 4242 5e3c5fe2cb14
permissions -rw-r--r--
This change allows computers limited to 512 texture size like szczur's card to run Hedgewars, so long as reduce quality is set to eliminate background textures. It makes Ammo menu and Hats multicolumn, 512 high.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3435
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module HWProtoInRoomState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
     4
import qualified Data.Foldable as Foldable
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import qualified Data.Map as Map
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Data.Sequence(Seq, (|>), (><), fromList, empty)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Data.List
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
     8
import Data.Maybe
3531
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
     9
import qualified Data.ByteString.Char8 as B
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    10
import Control.Monad
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    11
import Control.Monad.Reader
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import Utils
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2960
diff changeset
    16
import HandlerUtils
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    17
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
handleCmd_inRoom :: CmdHandler
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2960
diff changeset
    21
handleCmd_inRoom ["CHAT", msg] = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2960
diff changeset
    22
    n <- clientNick
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2960
diff changeset
    23
    s <- roomOthersChans
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2960
diff changeset
    24
    return [AnswerClients s ["CHAT", n, msg]]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
3531
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
    26
handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
    27
handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
    28
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
    29
3540
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    30
handleCmd_inRoom ("CFG" : paramName : paramStrs)
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    31
    | null paramStrs = return [ProtocolError "Empty config entry"]
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    32
    | otherwise = do
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    33
        chans <- roomOthersChans
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    34
        cl <- thisClient
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    35
        if isMaster cl then
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    36
           return [
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    37
                ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    38
                AnswerClients chans ("CFG" : paramName : paramStrs)]
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    39
            else
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3531
diff changeset
    40
            return [ProtocolError "Not room master"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
3544
aad64e15ca03 Start reimplementation of ADD_TEAM
unc0rr
parents: 3543
diff changeset
    42
handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
aad64e15ca03 Start reimplementation of ADD_TEAM
unc0rr
parents: 3543
diff changeset
    43
    | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"]
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    44
    | otherwise = do
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    45
        (ci, rnc) <- ask
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
    46
        r <- thisRoom
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    47
        clNick <- clientNick
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    48
        clChan <- thisClientChans
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    49
        othersChans <- roomOthersChans
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    50
        return $
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3564
diff changeset
    51
            if not . null . drop 5 $ teams r then
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    52
                [Warning "too many teams"]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    53
            else if canAddNumber r <= 0 then
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    54
                [Warning "too many hedgehogs"]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    55
            else if isJust $ findTeam r then
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    56
                [Warning "There's already a team with same name in the list"]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    57
            else if gameinprogress r then
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    58
                [Warning "round in progress"]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    59
            else if isRestrictedTeams r then
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    60
                [Warning "restricted"]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    61
            else
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    62
                [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}),
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    63
                ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    64
                AnswerClients clChan ["TEAM_ACCEPTED", name],
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    65
                AnswerClients othersChans $ teamToNet $ newTeam ci clNick r,
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    66
                AnswerClients othersChans ["TEAM_COLOR", name, color]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    67
                ]
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    68
        where
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    69
        canAddNumber r = 48 - (sum . map hhnum $ teams r)
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    70
        findTeam = find (\t -> name == teamname t) . teams
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    71
        newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo))
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    72
        difficulty = case B.readInt difStr of
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    73
                           Just (i, t) | B.null t -> fromIntegral i
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    74
                           otherwise -> 0
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    75
        hhsList [] = []
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3564
diff changeset
    76
        hhsList [_] = error "Hedgehogs list with odd elements number"
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    77
        hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3544
diff changeset
    78
        newTeamHHNum r = min 4 (canAddNumber r)
3561
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
    79
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
    80
handleCmd_inRoom ["REMOVE_TEAM", name] = do
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
    81
        (ci, rnc) <- ask
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
    82
        r <- thisRoom
3564
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    83
        clNick <- clientNick
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    84
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    85
        let maybeTeam = findTeam r
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    86
        let team = fromJust maybeTeam
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    87
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    88
        return $
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    89
            if isNothing $ findTeam r then
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    90
                [Warning "REMOVE_TEAM: no such team"]
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    91
            else if clNick /= teamowner team then
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    92
                [ProtocolError "Not team owner!"]
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    93
            else
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    94
                [RemoveTeam name,
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    95
                ModifyClient
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    96
                    (\c -> c{
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    97
                        teamsInGame = teamsInGame c - 1,
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    98
                        clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
    99
                        })
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
   100
                ]
3561
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
   101
    where
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
   102
        anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
3564
7c583c88327b Reimplement REMOVE_TEAM
unc0rr
parents: 3561
diff changeset
   103
        findTeam = find (\t -> name == teamname t) . teams
3561
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
   104
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   105
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   106
handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   107
    cl <- thisClient
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   108
    others <- roomOthersChans
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   109
    r <- thisRoom
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   110
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   111
    let maybeTeam = findTeam r
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   112
    let team = fromJust maybeTeam
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   113
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   114
    return $
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   115
        if not $ isMaster cl then
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   116
            [ProtocolError "Not room master"]
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   117
        else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   118
            []
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   119
        else
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   120
            [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   121
            AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   122
    where
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   123
        hhNumber = case B.readInt numberStr of
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   124
                           Just (i, t) | B.null t -> fromIntegral i
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   125
                           otherwise -> 0
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   126
        findTeam = find (\t -> teamName == teamname t) . teams
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   127
        canAddNumber = (-) 48 . sum . map hhnum . teams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   128
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   129
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   130
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   131
handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   132
    cl <- thisClient
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   133
    others <- roomOthersChans
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   134
    r <- thisRoom
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   135
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   136
    let maybeTeam = findTeam r
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   137
    let team = fromJust maybeTeam
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   138
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   139
    return $
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   140
        if not $ isMaster cl then
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   141
            [ProtocolError "Not room master"]
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   142
        else if isNothing maybeTeam then
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   143
            []
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   144
        else
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   145
            [ModifyRoom $ modifyTeam team{teamcolor = newColor},
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   146
            AnswerClients others ["TEAM_COLOR", teamName, newColor],
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   147
            ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   148
    where
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   149
        findTeam = find (\t -> teamName == teamname t) . teams
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   150
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   151
3543
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   152
handleCmd_inRoom ["TOGGLE_READY"] = do
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   153
    cl <- thisClient
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   154
    chans <- roomClientsChans
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   155
    return [
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   156
        ModifyClient (\c -> c{isReady = not $ isReady cl}),
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   157
        ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}),
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   158
        AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl]
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3540
diff changeset
   159
        ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   160
3577
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   161
handleCmd_inRoom ["START_GAME"] = do
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   162
    cl <- thisClient
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   163
    r <- thisRoom
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   164
    chans <- roomClientsChans
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   165
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   166
    if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   167
        if enoughClans r then
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   168
            return [
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   169
                ModifyRoom
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   170
                    (\r -> r{
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   171
                        gameinprogress = True,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   172
                        roundMsgs = empty,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   173
                        leftTeams = [],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   174
                        teamsAtStart = teams r}
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   175
                    ),
3577
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   176
                AnswerClients chans ["RUN_GAME"]
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   177
                ]
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   178
            else
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   179
            return [Warning "Less than two clans!"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   180
        else
3577
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   181
        return []
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   182
    where
3577
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   183
        enoughClans = not . null . drop 1 . group . map teamcolor . teams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   184
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   185
3579
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   186
handleCmd_inRoom ["EM", msg] = do
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   187
    cl <- thisClient
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   188
    r <- thisRoom
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   189
    chans <- roomOthersChans
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   190
    
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   191
    if (teamsInGame cl > 0) && isLegal then
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   192
        return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   193
        else
f5d28402ca1d Engine Message command
unc0rr
parents: 3577
diff changeset
   194
        return []
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   195
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   196
        (isLegal, isKeepAlive) = checkNetCmd msg
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   197
3655
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   198
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   199
handleCmd_inRoom ["ROUNDFINISHED"] = do
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   200
    cl <- thisClient
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   201
    r <- thisRoom
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   202
    chans <- roomClientsChans
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   203
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   204
    if isMaster cl && (gameinprogress r) then
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   205
        return $ (ModifyRoom
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   206
                (\r -> r{
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   207
                    gameinprogress = False,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   208
                    readyPlayers = 0,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   209
                    roundMsgs = empty,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   210
                    leftTeams = [],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   211
                    teamsAtStart = []}
3655
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   212
                ))
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   213
            : UnreadyRoomClients
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   214
            : answerRemovedTeams chans r
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   215
        else
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   216
        return []
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   217
    where
3655
1ae653467897 Reimplement ROUNDFINISHED
unc0rr
parents: 3579
diff changeset
   218
        answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   219
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   220
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   221
    cl <- thisClient
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   222
    return $
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   223
        if not $ isMaster cl then
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   224
            [ProtocolError "Not room master"]
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   225
        else
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   226
            [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   227
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   228
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   229
handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   230
    cl <- thisClient
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   231
    return $
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   232
        if not $ isMaster cl then
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   233
            [ProtocolError "Not room master"]
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   234
        else
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   235
            [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
1831
025348f05b9f Implement two more missing protocol commands
unc0rr
parents: 1818
diff changeset
   236
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   237
{-
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   238
handleCmd_inRoom clID clients rooms ["KICK", kickNick] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   239
    [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   240
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   241
        client = clients IntMap.! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   242
        maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   243
        noSuchClient = isNothing maybeClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   244
        kickClient = fromJust maybeClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   245
        kickID = clientUID kickClient
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   246
1831
025348f05b9f Implement two more missing protocol commands
unc0rr
parents: 1818
diff changeset
   247
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2381
diff changeset
   248
handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] =
2960
b467a681c5e0 - Fix spectators team chat
unc0rr
parents: 2952
diff changeset
   249
    [AnswerSameClan ["EM", engineMsg]]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   250
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   251
        client = clients IntMap.! clID
2952
18fada739b55 - Convert strings from utf-8 on recieve, and back to utf-8 when send them
unc0rr
parents: 2928
diff changeset
   252
        engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
3531
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
   253
-}
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
   254
handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]