author  unc0rr 
Sat, 23 Jul 2011 09:30:51 +0400  
changeset 5426  109e9b5761c2 
parent 5209  f7a610e2ef5f 
child 5573  cc409ee3ad2e 
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 
1804  9 
 
10 
import CoreTypes 

11 
import Actions 

12 
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

13 
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

14 
import RoomsAndClients 
1804  15 

4932  16 

4989  17 
answerAllTeams :: ClientInfo > [TeamInfo] > [Action] 
4591  18 
answerAllTeams cl = concatMap toAnswer 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

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

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

5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

24 
AnswerClients [clChan] ["HH_NUM", teamname team, showB $ hhnum team]] 
4568  25 

4989  26 
handleCmd_lobby :: CmdHandler 
1804  27 

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

28 

1f5604cd99be
This revision should, in 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_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

30 
(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

31 
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

32 
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

33 
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

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

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

38 
name r, 

39 
showB $ playersIn r, 

40 
showB $ length $ teams r, 

41 
nick $ irnc `client` masterID r, 

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

42 
Map.findWithDefault "+rnd+" "MAP" (mapParams r), 
4932  43 
head (Map.findWithDefault ["Default"] "SCHEME" (params r)), 
4941  44 
head (Map.findWithDefault ["Default"] "AMMO" (params r)) 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

45 
] 
3501  46 

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

47 

1f5604cd99be
This revision should, in 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 
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

49 
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

50 
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

51 
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

52 

4932  53 
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword] 
54 
 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

55 
 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

56 
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

57 
cl < thisClient 
4932  58 
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

59 
[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

60 
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

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

63 
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

64 
] 
1804  65 

3536  66 

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

3536  69 

1862  70 

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

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

73 
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

74 
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

75 
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

76 
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

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

78 
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

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

80 
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

81 
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

82 
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

83 
[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

84 
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

85 
[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

86 
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

87 
[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

88 
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

89 
[ 
1f5604cd99be
This revision should, in 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 
MoveToRoom jRI, 
4597
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

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

92 
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

93 
] 
4932  94 
++ map (readynessMessage cl) jRoomClients 
4941  95 
++ answerFullConfig cl (mapParams jRoom) (params jRoom) 
4932  96 
++ answerTeams cl jRoom 
97 
++ watchRound cl jRoom 

1804  98 

4587  99 
where 
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

100 
readynessMessage cl c = AnswerClients [sendChan cl] $ 
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

101 
if clientProto cl < 38 then 
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

102 
[if isReady c then "READY" else "NOT_READY", nick c] 
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

103 
else 
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

104 
["CLIENT_FLAGS", if isReady c then "+r" else "r", nick c] 
3536  105 

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

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

108 
answerFullConfig cl mpr pr 
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

109 
 clientProto cl < 38 = map (toAnswer cl) $ 
4984  110 
(reverse . map (\(a, b) > (a, [b])) $ Map.toList mpr) 
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

111 
++ (("SCHEME", pr Map.! "SCHEME") 
4984  112 
: (filter (\(p, _) > p /= "SCHEME") $ Map.toList pr)) 
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

113 

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

114 
 otherwise = map (toAnswer cl) $ 
4941  115 
("FULLMAPCONFIG", Map.elems mpr) 
4936
d65d438acd23
Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents:
4932
diff
changeset

116 
: ("SCHEME", pr Map.! "SCHEME") 
4941  117 
: (filter (\(p, _) > p /= "SCHEME") $ Map.toList pr) 
4587  118 

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

4595  121 
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

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

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

1813  126 

3536  127 

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

128 
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

129 
handleCmd_lobby ["JOIN_ROOM", roomName, ""] 
4568  130 

1804  131 

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

134 
ci < clientByNick asknick 

135 
let ri = clientRoom rnc $ fromJust ci 

136 
let clRoom = room rnc ri 

137 
if isNothing ci  ri == lobbyId then 

138 
return [] 

139 
else 

140 
handleCmd_lobby ["JOIN_ROOM", name clRoom] 

1862  141 

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

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

143 
 Administrator's stuff  
1862  144 

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

147 
cl < thisClient 

148 
kickId < clientByNick kickNick 

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

1866  150 

4909  151 

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

153 
(ci, _) < ask 

154 
cl < thisClient 

155 
banId < clientByNick banNick 

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

5426
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

157 

109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

158 
handleCmd_lobby ["BANIP", ip, reason, duration] = do 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

159 
(ci, _) < ask 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

160 
cl < thisClient 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

161 
return [BanIP ip (readInt_ duration) reason  isAdministrator cl] 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

162 

109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

163 
handleCmd_lobby ["BANLIST"] = do 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

164 
(ci, _) < ask 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

165 
cl < thisClient 
109e9b5761c2
Implement command for banning by ip and a command for bans list
unc0rr
parents:
5209
diff
changeset

166 
return [BanList  isAdministrator cl] 
1804  167 

3283  168 

4620  169 
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do 
170 
cl < thisClient 

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

1925  172 

4620  173 
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do 
174 
cl < thisClient 

175 
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

176 

4620  177 
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do 
178 
cl < thisClient 

179 
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

180 
where 
5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

181 
readNum = readInt_ protoNum 
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

182 

4620  183 
handleCmd_lobby ["GET_SERVER_VAR"] = do 
184 
cl < thisClient 

185 
return [SendServerVars  isAdministrator cl] 

3283  186 

4620  187 
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do 
188 
cl < thisClient 

189 
return [ClearAccountsCache  isAdministrator cl] 

3283  190 

5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset

191 
handleCmd_lobby ["RESTART_SERVER"] = do 
4914  192 
cl < thisClient 
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset

193 
return [RestartServer] 
4914  194 

3283  195 

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 
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"] 