← Back to branch summary

~ubuntu-branches/ubuntu/utopic/hedgewars/utopic

« back to all changes in this revision

Viewing changes to gameServer/HWProtoLobbyState.hs

  • Committer: Package Import Robot
  • Author(s): Gianfranco Costamagna
  • Date: 2014-01-02 12:37:23 UTC
  • mfrom: (19.1.5 sid)
  • Revision ID: package-import@ubuntu.com-20140102123723-6pdhmyj8tb5y8xbg
Tags: 0.9.20.3-1
New upstream minor release, suitable for unstable

Show diffs side-by-side

added added

removed removed

Lines of Context:
gameServer/HWProtoLobbyState.hs
1
1
{-# LANGUAGE OverloadedStrings #-}
2
2
module HWProtoLobbyState where
3
3
 
4
 
import qualified Data.Map as Map
5
4
import Data.Maybe
6
5
import Data.List
7
6
import Control.Monad.Reader
 
7
import qualified Data.ByteString.Char8 as B
8
8
--------------------------------------
9
9
import CoreTypes
10
10
import Actions
14
14
import EngineInteraction
15
15
 
16
16
 
17
 
answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
18
 
answerAllTeams cl = concatMap toAnswer
19
 
    where
20
 
        clChan = sendChan cl
21
 
        toAnswer team =
22
 
            [AnswerClients [clChan] $ teamToNet team,
23
 
            AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
24
 
            AnswerClients [clChan] ["HH_NUM", teamname team, showB $ hhnum team]]
25
 
 
26
 
 
27
17
handleCmd_lobby :: CmdHandler
28
18
 
29
19
 
31
21
    (ci, irnc) <- ask
32
22
    let cl = irnc `client` ci
33
23
    rooms <- allRoomInfos
34
 
    let roomsInfoList = concatMap (\r -> roomInfo (nick $ irnc `client` masterID r) r) . filter (\r -> (roomProto r == clientProto cl))
 
24
    let roomsInfoList = concatMap (\r -> roomInfo (clientProto cl) (maybeNick . liftM (client irnc) $ masterID r) r) . filter (\r -> (roomProto r == clientProto cl))
35
25
    return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
36
26
 
37
 
 
38
27
handleCmd_lobby ["CHAT", msg] = do
39
28
    n <- clientNick
40
29
    s <- roomOthersChans
51
40
            [
52
41
                AddRoom rName roomPassword
53
42
                , AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+hr", nick cl]
54
 
                , ModifyClient (\c -> c{isMaster = True, isReady = True})
 
43
                , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
55
44
                , ModifyRoom (\r -> r{readyPlayers = 1})
56
45
            ]
57
46
 
70
59
    let sameProto = clientProto cl == roomProto jRoom
71
60
    let jRoomClients = map (client irnc) $ roomClients irnc jRI
72
61
    let nicks = map nick jRoomClients
73
 
    let ownerNick = nick . fromJust $ find isMaster jRoomClients
 
62
    let owner = find isMaster jRoomClients
74
63
    let chans = map sendChan (cl : jRoomClients)
75
64
    let isBanned = host cl `elem` roomBansList jRoom
76
65
    return $
77
 
        if isNothing maybeRI || not sameProto then
 
66
        if isNothing maybeRI then
78
67
            [Warning $ loc "No such room"]
 
68
            else if not sameProto then
 
69
            [Warning $ loc "Room version incompatible to your hedgewars version"]
79
70
            else if isRestrictedJoins jRoom then
80
71
            [Warning $ loc "Joining restricted"]
81
 
            else if isRegisteredOnly jRoom then
 
72
            else if isRegisteredOnly jRoom && (B.null . webPassword $ cl) && not (isAdministrator cl) then
82
73
            [Warning $ loc "Registered users only"]
83
74
            else if isBanned then
84
75
            [Warning $ loc "You are banned in this room"]
85
76
            else if roomPassword /= password jRoom then
86
77
            [NoticeMessage WrongPassword]
87
78
            else
88
 
            [
 
79
            (
89
80
                MoveToRoom jRI
90
 
                , AnswerClients [sendChan cl] $ "JOINED" : nicks
91
 
                , AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
92
 
                , AnswerClients [sendChan cl] $ ["CLIENT_FLAGS", "+h", ownerNick]
93
 
            ]
94
 
            ++ (if clientProto cl < 38 then map (readynessMessage cl) jRoomClients else [sendStateFlags cl jRoomClients])
95
 
            ++ answerFullConfig cl (mapParams jRoom) (params jRoom)
 
81
                : ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom})
 
82
                : AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
 
83
                : [(AnswerClients [sendChan cl] $ "JOINED" : nicks) | not $ null nicks]
 
84
            )
 
85
            ++ [AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+h", nick $ fromJust owner] | isJust owner]
 
86
            ++ [sendStateFlags cl jRoomClients | not $ null jRoomClients]
 
87
            ++ answerFullConfig cl jRoom
96
88
            ++ answerTeams cl jRoom
97
89
            ++ watchRound cl jRoom chans
 
90
            ++ [AnswerClients [sendChan cl] ["CHAT", "[greeting]", greeting jRoom] | greeting jRoom /= ""]
98
91
 
99
92
        where
100
 
        readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c]
101
93
        sendStateFlags cl clients = AnswerClients [sendChan cl] . concat . intersperse [""] . filter (not . null) . concat $
102
94
                [f "+r" ready, f "-r" unready, f "+g" ingame, f "-g" inroomlobby]
103
95
            where
105
97
            (ingame, inroomlobby) = partition isInGame clients
106
98
            f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
107
99
 
108
 
        toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs
109
 
 
110
 
        answerFullConfig cl mpr pr
111
 
            | clientProto cl < 38 = map (toAnswer cl) $
112
 
                 (reverse . map (\(a, b) -> (a, [b])) $ Map.toList mpr)
113
 
                 ++ (("SCHEME", pr Map.! "SCHEME")
114
 
                 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr))
115
 
 
116
 
            | otherwise = map (toAnswer cl) $
117
 
                 ("FULLMAPCONFIG", Map.elems mpr)
118
 
                 : ("SCHEME", pr Map.! "SCHEME")
119
 
                 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr)
 
100
        -- get config from gameInfo if possible, otherwise from room
 
101
        answerFullConfig cl jRoom = let f r g = (if isJust $ gameInfo jRoom then g . fromJust . gameInfo else r) jRoom
 
102
                                    in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
120
103
 
121
104
        answerTeams cl jRoom = let f = if isJust $ gameInfo jRoom then teamsAtStart . fromJust . gameInfo else teams in answerAllTeams cl $ f jRoom
122
105
 
123
106
        watchRound cl jRoom chans = if isNothing $ gameInfo jRoom then
124
107
                    []
125
108
                else
126
 
                    [AnswerClients [sendChan cl]  ["RUN_GAME"]
127
 
                    , AnswerClients chans ["CLIENT_FLAGS", "+g", nick cl]
128
 
                    , ModifyClient (\c -> c{isInGame = True})
129
 
                    , AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
 
109
                    AnswerClients [sendChan cl]  ["RUN_GAME"]
 
110
                    : AnswerClients chans ["CLIENT_FLAGS", "+g", nick cl]
 
111
                    : ModifyClient (\c -> c{isInGame = True})
 
112
                    : [AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
130
113
 
131
114
 
132
115
handleCmd_lobby ["JOIN_ROOM", roomName] =