author  unc0rr 
Sun, 06 Feb 2011 21:50:29 +0300  
changeset 4932  f11d80bac7ed 
parent 4917  8ff92bdc9f98 
child 4936  d65d438acd23 
permissions  rwrr 
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  2 
module HWProtoLobbyState where 
3 

4 
import qualified Data.Map as Map 

1813  5 
import qualified Data.Foldable as Foldable 
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 
1804  7 
import Data.List 
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

8 
import Control.Monad.Reader 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

9 
import qualified Data.ByteString.Char8 as B 
1804  10 
 
11 
import CoreTypes 

12 
import Actions 

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 
1804  16 

4932  17 

18 
answerAllTeams :: ClientInfo > [TeamInfo] > [Action] 

4591  19 
answerAllTeams cl = concatMap toAnswer 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

20 
where 
4591  21 
clChan = sendChan cl 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

22 
toAnswer team = 
4591  23 
[AnswerClients [clChan] $ teamToNet team, 
24 
AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team], 

25 
AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]] 

4568  26 

1804  27 
handleCmd_lobby :: CmdHandler 
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 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

30 
handleCmd_lobby ["LIST"] = 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

31 
(ci, irnc) < ask 
1f5604cd99be
This revision should, in 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 
let cl = irnc `client` ci 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

33 
rooms < allRoomInfos 
1f5604cd99be
This revision should, in 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 
let roomsInfoList = concatMap (roomInfo irnc) . filter (\r > (roomProto r == clientProto cl) && not (isRestrictedJoins 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

35 
return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

36 
where 
4932  37 
roomInfo irnc r = [ 
38 
showB $ gameinprogress r, 

39 
name r, 

40 
showB $ playersIn r, 

41 
showB $ length $ teams r, 

42 
nick $ irnc `client` masterID r, 

43 
head (Map.findWithDefault ["+gen+"] "MAP" (params r)), 

44 
head (Map.findWithDefault ["Default"] "SCHEME" (params r)), 

45 
head (Map.findWithDefault ["Default"] "AMMO" (params r)) 

2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

46 
] 
3501  47 

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 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

49 
handleCmd_lobby ["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

50 
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

51 
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

52 
return [AnswerClients s ["CHAT", n, msg]] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

53 

4932  54 
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword] 
55 
 illegalName rName = return [Warning "Illegal room name"] 

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

56 
 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

57 
rs < allRoomInfos 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

58 
cl < thisClient 
4932  59 
return $ if isJust $ find (\r > rName == name r) rs 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

60 
[Warning "Room exists"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

61 
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

62 
[ 
4932  63 
AddRoom rName roomPassword, 
4917
8ff92bdc9f98
Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents:
4914
diff
changeset

64 
AnswerClients [sendChan cl] ["CLIENT_FLAGS", "r", nick cl] 
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

65 
] 
1804  66 

3536  67 

4932  68 
handleCmd_lobby ["CREATE_ROOM", rName] = 
69 
handleCmd_lobby ["CREATE_ROOM", rName, ""] 

3536  70 

1862  71 

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

72 
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do 
4932  73 
(_, irnc) < 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

74 
let ris = allRooms irnc 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

75 
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

76 
let maybeRI = find (\ri > roomName == name (irnc `room` ri)) ris 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

77 
let jRI = fromJust maybeRI 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

78 
let jRoom = irnc `room` jRI 
4597
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

79 
let jRoomClients = map (client irnc) $ roomClients irnc jRI 
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

80 
let nicks = map nick jRoomClients 
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

81 
let chans = map sendChan (cl : jRoomClients) 
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

82 
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

83 
if isNothing maybeRI 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

84 
[Warning "No such rooms"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

85 
else if isRestrictedJoins jRoom 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

86 
[Warning "Joining restricted"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

87 
else if roomPassword /= password jRoom 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

88 
[Warning "Wrong password"] 
1f5604cd99be
This revision should, in 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 
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

90 
[ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

91 
MoveToRoom jRI, 
4597
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

92 
AnswerClients [sendChan cl] $ "JOINED" : nicks, 
4917
8ff92bdc9f98
Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents:
4914
diff
changeset

93 
AnswerClients chans ["CLIENT_FLAGS", "r", nick cl] 
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

94 
] 
4932  95 
++ map (readynessMessage cl) jRoomClients 
96 
++ answerFullConfig cl (params jRoom) 

97 
++ answerTeams cl jRoom 

98 
++ watchRound cl jRoom 

1804  99 

4587  100 
where 
4917
8ff92bdc9f98
Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents:
4914
diff
changeset

101 
readynessMessage cl c = AnswerClients [sendChan cl] ["CLIENT_FLAGS", if isReady c then "+r" else "r", nick c] 
3536  102 

4587  103 
toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs 
1813  104 

4932  105 
answerFullConfig cl pr = map (toAnswer cl) (leftConfigPart ++ rightConfigPart) 
4587  106 
where 
4932  107 
(leftConfigPart, rightConfigPart) = partition (\(p, _) > p /= "MAP") $ Map.toList pr 
4587  108 

4591  109 
answerTeams cl jRoom = let f = if gameinprogress jRoom then teamsAtStart else teams in answerAllTeams cl $ f jRoom 
110 

4595  111 
watchRound cl jRoom = if not $ gameinprogress jRoom then 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

112 
[] 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

113 
else 
4595  114 
[AnswerClients [sendChan cl] ["RUN_GAME"], 
115 
AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)] 

1813  116 

3536  117 

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

118 
handleCmd_lobby ["JOIN_ROOM", roomName] = 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

119 
handleCmd_lobby ["JOIN_ROOM", roomName, ""] 
4568  120 

1804  121 

4616  122 
handleCmd_lobby ["FOLLOW", asknick] = do 
123 
(_, rnc) < ask 

124 
ci < clientByNick asknick 

125 
let ri = clientRoom rnc $ fromJust ci 

126 
let clRoom = room rnc ri 

127 
if isNothing ci  ri == lobbyId then 

128 
return [] 

129 
else 

130 
handleCmd_lobby ["JOIN_ROOM", name clRoom] 

1862  131 

2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

132 
 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

133 
 Administrator's stuff  
1862  134 

4618  135 
handleCmd_lobby ["KICK", kickNick] = do 
136 
(ci, _) < ask 

137 
cl < thisClient 

138 
kickId < clientByNick kickNick 

139 
return [KickClient $ fromJust kickId  isAdministrator cl && isJust kickId && fromJust kickId /= ci] 

1866  140 

4909  141 

142 
handleCmd_lobby ["BAN", banNick, reason] = do 

143 
(ci, _) < ask 

144 
cl < thisClient 

145 
banId < clientByNick banNick 

146 
return [BanClient 60 reason (fromJust banId)  isAdministrator cl && isJust banId && fromJust banId /= ci] 

1804  147 

3283  148 

4620  149 
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do 
150 
cl < thisClient 

151 
return [ModifyServerInfo (\si > si{serverMessage = newMessage})  isAdministrator cl] 

1925  152 

4620  153 
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do 
154 
cl < thisClient 

155 
return [ModifyServerInfo (\si > si{serverMessageForOldVersions = newMessage})  isAdministrator cl] 

3260
b44b88908758
Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents:
2961
diff
changeset

156 

4620  157 
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do 
158 
cl < thisClient 

159 
return [ModifyServerInfo (\si > si{latestReleaseVersion = readNum})  isAdministrator cl && readNum > 0] 

3260
b44b88908758
Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents:
2961
diff
changeset

160 
where 
4620  161 
readNum = case B.readInt protoNum of 
162 
Just (i, t)  B.null t > fromIntegral i 

4932  163 
_ > 0 
1925  164 

4620  165 
handleCmd_lobby ["GET_SERVER_VAR"] = do 
166 
cl < thisClient 

167 
return [SendServerVars  isAdministrator cl] 

3283  168 

4620  169 
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do 
170 
cl < thisClient 

171 
return [ClearAccountsCache  isAdministrator cl] 

3283  172 

4914  173 
handleCmd_lobby ["RESTART_SERVER", restartType] = do 
174 
cl < thisClient 

175 
return [RestartServer f  let f = restartType == "FORCE", isAdministrator cl] 

176 

3283  177 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

178 
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"] 