gameServer/HWProtoInRoomState.hs
author koda
Mon, 25 Feb 2013 00:24:09 +0100
branchphysfslayer
changeset 8552 6c63c2833866
parent 8514 896b283f41a2
child 8525 81630d47dc0f
permissions -rw-r--r--
upd doc
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 HWProtoInRoomState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import qualified Data.Map as Map
7862
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
     5
import Data.List as L
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
     6
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
     7
import qualified Data.ByteString.Char8 as B
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     8
import Control.Monad
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     9
import Control.Monad.Reader
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
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
    14
import HandlerUtils
1f5604cd99be This revision should, in 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 RoomsAndClients
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 6012
diff changeset
    16
import EngineInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4986
diff changeset
    18
handleCmd_inRoom :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    20
handleCmd_inRoom ["CHAT", 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
    21
    n <- 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
    22
    s <- roomOthersChans
1f5604cd99be This revision should, in 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
    return [AnswerClients s ["CHAT", n, msg]]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
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
    25
handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
1f5604cd99be This revision should, in 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
handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
3531
66c403badff6 Reimplement room creating
unC0Rr@gmail.com
parents: 3500
diff changeset
    27
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
    28
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
    29
handleCmd_inRoom ("CFG" : paramName : paramStrs)
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    30
    | null paramStrs = return [ProtocolError $ loc "Empty config entry"]
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
    | otherwise = 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
    32
        chans <- roomOthersChans
1f5604cd99be This revision should, in 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
        cl <- thisClient
1f5604cd99be This revision should, in 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
        if isMaster cl 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
    35
           return [
4941
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4932
diff changeset
    36
                ModifyRoom f,
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
    37
                AnswerClients chans ("CFG" : paramName : paramStrs)]
1f5604cd99be This revision should, in 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
            else
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    39
            return [ProtocolError $ loc "Not room master"]
4941
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4932
diff changeset
    40
    where
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4932
diff changeset
    41
        f r = if paramName `Map.member` (mapParams r) then
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4932
diff changeset
    42
                r{mapParams = Map.insert paramName (head paramStrs) (mapParams r)}
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4932
diff changeset
    43
                else
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4932
diff changeset
    44
                r{params = Map.insert paramName paramStrs (params r)}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    46
handleCmd_inRoom ("ADD_TEAM" : tName : color : grave : fort : voicepack : flag : difStr : hhsInfo)
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    47
    | length hhsInfo /= 16 = return [ProtocolError $ loc "Corrupted hedgehogs info"]
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
    48
    | otherwise = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    49
        (ci, _) <- ask
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    50
        rm <- thisRoom
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
    51
        clNick <- 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
    52
        clChan <- thisClientChans
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    53
        othChans <- roomOthersChans
7862
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    54
        roomChans <- roomClientsChans
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    55
        cl <- thisClient
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    56
        teamColor <-
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    57
            if clientProto cl < 42 then 
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    58
                return color
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    59
                else
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    60
                liftM (head . (L.\\) (map B.singleton ['0'..]) . map teamcolor . teams) thisRoom
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    61
        let roomTeams = teams rm
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    62
        let hhNum = let p = if not $ null roomTeams then hhnum $ head roomTeams else 4 in newTeamHHNum roomTeams p
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    63
        let newTeam = clNick `seq` TeamInfo ci clNick tName teamColor grave fort voicepack flag dif hhNum (hhsList hhsInfo)
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
        return $
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    65
            if not . null . drop (maxTeams rm - 1) $ roomTeams then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    66
                [Warning $ loc "too many teams"]
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    67
            else if canAddNumber roomTeams <= 0 then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    68
                [Warning $ loc "too many hedgehogs"]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    69
            else if isJust $ findTeam rm then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    70
                [Warning $ loc "There's already a team with same name in the list"]
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5931
diff changeset
    71
            else if isJust $ gameInfo rm then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    72
                [Warning $ loc "round in progress"]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    73
            else if isRestrictedTeams rm then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    74
                [Warning $ loc "restricted"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    75
            else
7986
53b1da5ee7f4 Maybe this caused server crashes? Add more strictness on team owner record field
unc0rr
parents: 7947
diff changeset
    76
                [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7862
diff changeset
    77
                SendUpdateOnThisRoom,
7862
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    78
                ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = Just teamColor}),
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    79
                AnswerClients clChan ["TEAM_ACCEPTED", tName],
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    80
                AnswerClients clChan ["HH_NUM", tName, showB $ hhnum newTeam],
7986
53b1da5ee7f4 Maybe this caused server crashes? Add more strictness on team owner record field
unc0rr
parents: 7947
diff changeset
    81
                AnswerClients othChans $ teamToNet $ newTeam,
7862
bd76ca40db68 Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents: 7775
diff changeset
    82
                AnswerClients roomChans ["TEAM_COLOR", tName, teamColor]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    83
                ]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    84
        where
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    85
        canAddNumber rt = (48::Int) - (sum $ map hhnum rt)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    86
        findTeam = find (\t -> tName == teamname t) . teams
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
    87
        dif = readInt_ difStr
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
    88
        hhsList [] = []
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    89
        hhsList [_] = error "Hedgehogs list with odd elements number"
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    90
        hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
    91
        newTeamHHNum rt p = min p (canAddNumber rt)
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7266
diff changeset
    92
        maxTeams r
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5143
diff changeset
    93
            | roomProto r < 38 = 6
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5143
diff changeset
    94
            | otherwise = 8
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7266
diff changeset
    95
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
    96
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    97
handleCmd_inRoom ["REMOVE_TEAM", tName] = do
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
    98
        (ci, _) <- ask
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
    99
        r <- thisRoom
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in 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
        let maybeTeam = findTeam 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
   102
        let team = fromJust maybeTeam
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in 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
        return $
8428
73ab5a17ee55 Fix crashers
unc0rr
parents: 8422
diff changeset
   105
            if isNothing $ maybeTeam then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   106
                [Warning $ loc "REMOVE_TEAM: no such team"]
8431
74c2c95ab07b Fix finding player's another clan
unc0rr
parents: 8429
diff changeset
   107
            else if ci /= teamownerId team then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   108
                [ProtocolError $ loc "Not team owner!"]
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
            else
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   110
                [RemoveTeam tName,
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   111
                ModifyClient
1f5604cd99be This revision should, in 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
                    (\c -> c{
1f5604cd99be This revision should, in 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
                        teamsInGame = teamsInGame c - 1,
8433
3b318a130a62 Some fixes
unc0rr
parents: 8431
diff changeset
   114
                        clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci team r
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4986
diff changeset
   115
                    })
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
   116
                ]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   117
    where
8433
3b318a130a62 Some fixes
unc0rr
parents: 8431
diff changeset
   118
        anotherTeamClan ci team = teamcolor . fromMaybe (error "CHECKPOINT 011") . find (\t -> (teamownerId t == ci) && (t /= team)) . teams
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   119
        findTeam = find (\t -> tName == teamname t) . teams
3561
7f8e07e4a4e3 Reimplement REMOVE_TEAM
unc0rr
parents: 3555
diff changeset
   120
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   121
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
   122
handleCmd_inRoom ["HH_NUM", teamName, numberStr] = 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
   123
    cl <- thisClient
1f5604cd99be This revision should, in 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
    r <- thisRoom
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
   125
    clChan <- thisClientChans
8477
330b0b8846cf Don't confirm hogs number to room admin when no constraint hit
unc0rr
parents: 8433
diff changeset
   126
    others <- roomOthersChans
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
   127
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   128
    let maybeTeam = findTeam 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
   129
    let team = fromJust maybeTeam
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   131
    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
   132
        if not $ isMaster cl then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   133
            [ProtocolError $ loc "Not room master"]
8429
f814a7c2a318 Oops, got too excited
unc0rr
parents: 8428
diff changeset
   134
        else if isNothing maybeTeam then
f814a7c2a318 Oops, got too excited
unc0rr
parents: 8428
diff changeset
   135
            []
8428
73ab5a17ee55 Fix crashers
unc0rr
parents: 8422
diff changeset
   136
        else if hhNumber < 1 || hhNumber > 8 || hhNumber > canAddNumber r + hhnum team then
8421
fc39fe044a4f Make number of hedgehogs restriction actually work in network game
unc0rr
parents: 8418
diff changeset
   137
            [AnswerClients clChan ["HH_NUM", teamName, showB $ hhnum team]]
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
   138
        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
   139
            [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
8477
330b0b8846cf Don't confirm hogs number to room admin when no constraint hit
unc0rr
parents: 8433
diff changeset
   140
            AnswerClients others ["HH_NUM", teamName, showB hhNumber]]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   141
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   142
        hhNumber = readInt_ numberStr
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
   143
        findTeam = find (\t -> teamName == teamname t) . teams
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   144
        canAddNumber = (-) 48 . sum . map hhnum . teams
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   145
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   146
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   147
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
   148
handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = 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
   149
    cl <- thisClient
1f5604cd99be This revision should, in 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
    others <- roomOthersChans
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   151
    r <- thisRoom
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in 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
    let maybeTeam = findTeam 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
   154
    let team = fromJust maybeTeam
1f5604cd99be This revision should, in 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
1f5604cd99be This revision should, in 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 $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   157
        if not $ isMaster cl then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   158
            [ProtocolError $ loc "Not room master"]
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
   159
        else if isNothing maybeTeam 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
   160
            []
1f5604cd99be This revision should, in 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
        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
   162
            [ModifyRoom $ modifyTeam team{teamcolor = newColor},
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   163
            AnswerClients others ["TEAM_COLOR", teamName, newColor],
4986
33fe91b2bcbf Use Maybe for storing client's clan, allows less error-prone spectator checks
unc0rr
parents: 4975
diff changeset
   164
            ModifyClient2 (teamownerId team) (\c -> c{clientClan = Just newColor})]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   165
    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
   166
        findTeam = find (\t -> teamName == teamname t) . teams
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3566
diff changeset
   167
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   168
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   169
handleCmd_inRoom ["TOGGLE_READY"] = 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
   170
    cl <- thisClient
1f5604cd99be This revision should, in 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
    chans <- roomClientsChans
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   172
    if isMaster cl then
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   173
        return []
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   174
        else
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   175
        return [
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   176
            ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}),
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   177
            ModifyClient (\c -> c{isReady = not $ isReady cl}),
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   178
            AnswerClients chans $ if clientProto cl < 38 then
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   179
                    [if isReady cl then "NOT_READY" else "READY", nick cl]
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   180
                    else
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   181
                    ["CLIENT_FLAGS", if isReady cl then "-r" else "+r", nick cl]
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
   182
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   183
8513
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   184
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
   185
handleCmd_inRoom ["START_GAME"] = do
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   186
    (ci, rnc) <- ask
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
   187
    cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   188
    rm <- thisRoom
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
    chans <- roomClientsChans
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7266
diff changeset
   190
7765
1e162c1d6dc7 'In game' client flag, both server and frontend support
unc0rr
parents: 7757
diff changeset
   191
    let nicks = map (nick . client rnc) . roomClients rnc $ clientRoom rnc ci
6012
6bac93097da3 Store replays for further analysis
unc0rr
parents: 5996
diff changeset
   192
    let allPlayersRegistered = all ((<) 0 . B.length . webPassword . client rnc . teamownerId) $ teams rm
3577
0ef6f5182a75 START_GAME command
unc0rr
parents: 3568
diff changeset
   193
8418
4543cc2049af Force-starting a game now only works for client versions >43
dag10
parents: 8416
diff changeset
   194
    if isMaster cl && (playersIn rm == readyPlayers rm || clientProto cl > 43) && not (isJust $ gameInfo rm) then
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   195
        if enoughClans rm then
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
   196
            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
   197
                ModifyRoom
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   198
                    (\r -> r{
6756
344d32bb1328 Also consider game finished when the last player reports ROUNDFINISHED despite the correctness parameter.
unc0rr
parents: 6753
diff changeset
   199
                        gameInfo = Just $ newGameInfo (teams rm) (length $ teams rm) allPlayersRegistered (mapParams rm) (params rm)
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5931
diff changeset
   200
                        }
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   201
                    )
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   202
                , AnswerClients chans ["RUN_GAME"]
7921
6b074de32bea Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents: 7862
diff changeset
   203
                , SendUpdateOnThisRoom
7765
1e162c1d6dc7 'In game' client flag, both server and frontend support
unc0rr
parents: 7757
diff changeset
   204
                , AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   205
                , ModifyRoomClients (\c -> c{isInGame = True})
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
   206
                ]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   207
            else
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   208
            return [Warning $ loc "Less than two clans!"]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   209
        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
   210
        return []
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   211
    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
   212
        enoughClans = not . null . drop 1 . group . map teamcolor . teams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   213
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   214
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
   215
handleCmd_inRoom ["EM", 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
   216
    cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   217
    rm <- thisRoom
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
   218
    chans <- roomOthersChans
4931
da43c36a6e92 Don't accept EM message when the game isn't started
unc0rr
parents: 4917
diff changeset
   219
8484
99c14f14f788 New checker of engine messages which is aware of glued together messages
unc0rr
parents: 8477
diff changeset
   220
    if teamsInGame cl > 0 && (isJust $ gameInfo rm) && (not $ B.null legalMsgs) then
99c14f14f788 New checker of engine messages which is aware of glued together messages
unc0rr
parents: 8477
diff changeset
   221
        return $ AnswerClients chans ["EM", legalMsgs]
99c14f14f788 New checker of engine messages which is aware of glued together messages
unc0rr
parents: 8477
diff changeset
   222
            : [ModifyRoom (\r -> r{gameInfo = liftM (\g -> g{roundMsgs = nonEmptyMsgs : roundMsgs g}) $ gameInfo r}) | not $ B.null nonEmptyMsgs]
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
   223
        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
   224
        return []
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   225
    where
8484
99c14f14f788 New checker of engine messages which is aware of glued together messages
unc0rr
parents: 8477
diff changeset
   226
        (legalMsgs, nonEmptyMsgs) = checkNetCmd msg
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   227
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
   228
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5931
diff changeset
   229
handleCmd_inRoom ["ROUNDFINISHED", correctly] = 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
   230
    cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   231
    rm <- thisRoom
7765
1e162c1d6dc7 'In game' client flag, both server and frontend support
unc0rr
parents: 7757
diff changeset
   232
    chans <- roomClientsChans
1e162c1d6dc7 'In game' client flag, both server and frontend support
unc0rr
parents: 7757
diff changeset
   233
6753
e95b1f62d0de Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents: 6738
diff changeset
   234
    let clTeams = map teamname . filter (\t -> teamowner t == nick cl) . teams $ rm
7765
1e162c1d6dc7 'In game' client flag, both server and frontend support
unc0rr
parents: 7757
diff changeset
   235
    let unsetInGameState = [AnswerClients chans ["CLIENT_FLAGS", "-g", nick cl], ModifyClient (\c -> c{isInGame = False})]
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
   236
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   237
    if isInGame cl then
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   238
        if isJust $ gameInfo rm then
8422
ec41194d4444 Okay, let's try not trust even room admin on this
unc0rr
parents: 8421
diff changeset
   239
            return $ unsetInGameState ++ map SendTeamRemovalMessage clTeams
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   240
            else
7765
1e162c1d6dc7 'In game' client flag, both server and frontend support
unc0rr
parents: 7757
diff changeset
   241
            return unsetInGameState
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
   242
        else
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 7537
diff changeset
   243
        return [] -- don't accept this message twice
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   244
    where
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5931
diff changeset
   245
        isCorrect = correctly == "1"
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   246
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   247
-- compatibility with clients with protocol < 38
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   248
handleCmd_inRoom ["ROUNDFINISHED"] =
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   249
    handleCmd_inRoom ["ROUNDFINISHED", "1"]
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   250
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   251
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = 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
   252
    cl <- thisClient
1f5604cd99be This revision should, in 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
    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
   254
        if not $ isMaster cl then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   255
            [ProtocolError $ loc "Not room master"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   256
        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
   257
            [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   258
1831
025348f05b9f Implement two more missing protocol commands
unc0rr
parents: 1818
diff changeset
   259
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   260
handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = 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
   261
    cl <- thisClient
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   262
    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
   263
        if not $ isMaster cl then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   264
            [ProtocolError $ loc "Not room master"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   265
        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
   266
            [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   267
1831
025348f05b9f Implement two more missing protocol commands
unc0rr
parents: 1818
diff changeset
   268
8232
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   269
handleCmd_inRoom ["TOGGLE_REGISTERED_ONLY"] = do
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   270
    cl <- thisClient
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   271
    return $
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   272
        if not $ isMaster cl then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   273
            [ProtocolError $ loc "Not room master"]
8232
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   274
        else
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   275
            [ModifyRoom (\r -> r{isRegisteredOnly = not $ isRegisteredOnly r})]
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8189
diff changeset
   276
8484
99c14f14f788 New checker of engine messages which is aware of glued together messages
unc0rr
parents: 8477
diff changeset
   277
5098
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   278
handleCmd_inRoom ["ROOM_NAME", newName] = do
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   279
    cl <- thisClient
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   280
    rs <- allRoomInfos
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6403
diff changeset
   281
    rm <- thisRoom
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6403
diff changeset
   282
    chans <- sameProtoChans
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7266
diff changeset
   283
5098
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   284
    return $
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   285
        if not $ isMaster cl then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   286
            [ProtocolError $ loc "Not room master"]
5098
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   287
        else
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   288
        if isJust $ find (\r -> newName == name r) rs then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   289
            [Warning $ loc "Room with such name already exists"]
5098
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   290
        else
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6403
diff changeset
   291
            [ModifyRoom roomUpdate,
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6403
diff changeset
   292
            AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo (nick cl) (roomUpdate rm))]
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6403
diff changeset
   293
    where
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6403
diff changeset
   294
        roomUpdate r = r{name = newName}
5098
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   295
cb9cf41a208c Allow to rename room
unc0rr
parents: 5030
diff changeset
   296
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   297
handleCmd_inRoom ["KICK", kickNick] = do
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   298
    (thisClientId, rnc) <- ask
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   299
    maybeClientId <- clientByNick kickNick
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   300
    master <- liftM isMaster thisClient
8513
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   301
    rm <- thisRoom
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   302
    let kickId = fromJust maybeClientId
8513
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   303
    let kickCl = rnc `client` kickId
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4931
diff changeset
   304
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
8513
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   305
    let notOnly2Clans = (length . group . sort . map teamcolor . teams $ rm) > 2
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   306
    return
8513
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   307
        [KickRoomClient kickId |
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   308
            master
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   309
            && isJust maybeClientId
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   310
            && (kickId /= thisClientId)
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   311
            && sameRoom
8514
896b283f41a2 Clear player's clan info on room join
unc0rr
parents: 8513
diff changeset
   312
            && ((isNothing $ gameInfo rm) || notOnly2Clans || teamsInGame kickCl == 0)
8513
cd85ab23f38b Disallow kicking the opponent in duel
unc0rr
parents: 8484
diff changeset
   313
        ]
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   314
1831
025348f05b9f Implement two more missing protocol commands
unc0rr
parents: 1818
diff changeset
   315
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   316
handleCmd_inRoom ["DELEGATE", newAdmin] = do
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   317
    (thisClientId, rnc) <- ask
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   318
    maybeClientId <- clientByNick newAdmin
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   319
    master <- liftM isMaster thisClient
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   320
    serverAdmin <- liftM isAdministrator thisClient
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   321
    let newAdminId = fromJust maybeClientId
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   322
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   323
    return
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   324
        [ChangeMaster (Just newAdminId) |
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   325
            (master || serverAdmin)
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   326
                && isJust maybeClientId
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   327
                && ((newAdminId /= thisClientId) || (serverAdmin && not master))
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   328
                && sameRoom]
8247
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   329
d7cf4a9ce685 Command to delegate room to other player
unc0rr
parents: 8232
diff changeset
   330
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   331
handleCmd_inRoom ["TEAMCHAT", msg] = do
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   332
    cl <- thisClient
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   333
    chans <- roomSameClanChans
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4337
diff changeset
   334
    return [AnswerClients chans ["EM", engineMsg cl]]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   335
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   336
        engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, "(team): ", msg, "\x20\x20"]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   337
8484
99c14f14f788 New checker of engine messages which is aware of glued together messages
unc0rr
parents: 8477
diff changeset
   338
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
   339
handleCmd_inRoom ["BAN", banNick] = do
8002
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   340
    (thisClientId, rnc) <- ask
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
   341
    maybeClientId <- clientByNick banNick
8002
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   342
    master <- liftM isMaster thisClient
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
   343
    let banId = fromJust maybeClientId
8002
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   344
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   345
    if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   346
        return [
8189
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8002
diff changeset
   347
--                ModifyRoom (\r -> r{roomBansList = let h = host $ rnc `client` banId in h `deepseq` h : roomBansList r})
328f429c3ecc - Disable in-room bans
unc0rr
parents: 8002
diff changeset
   348
                KickRoomClient banId
8002
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   349
            ]
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   350
        else
8113afd3858f More strictness on room bans
unc0rr
parents: 7986
diff changeset
   351
        return []
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
   352
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
   353
6912
831416764d2d Allow LIST command while in room to not annoy old frontends (0.9.17 or less) with warnings
unc0rr
parents: 6815
diff changeset
   354
handleCmd_inRoom ["LIST"] = return [] -- for old clients (<= 0.9.17)
831416764d2d Allow LIST command while in room to not annoy old frontends (0.9.17 or less) with warnings
unc0rr
parents: 6815
diff changeset
   355
6721
7dbf8a0c1f5d - Register HWTeam metatype so HWTeam objects could be passed via queued connections
unc0rr
parents: 6690
diff changeset
   356
handleCmd_inRoom (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: in room)"]
7dbf8a0c1f5d - Register HWTeam metatype so HWTeam objects could be passed via queued connections
unc0rr
parents: 6690
diff changeset
   357
7dbf8a0c1f5d - Register HWTeam metatype so HWTeam objects could be passed via queued connections
unc0rr
parents: 6690
diff changeset
   358
handleCmd_inRoom [] = return [ProtocolError "Empty command (state: in room)"]