author  unc0rr 
Sun, 30 Jan 2011 20:43:18 +0300  
branch  server_refactor 
changeset 4620  6122a43d3424 
parent 4618  0f56fa511f65 
child 4904  0eab727d4717 
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 

5 
import qualified Data.IntSet as IntSet 

1813  6 
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

7 
import Data.Maybe 
1804  8 
import Data.List 
3260
b44b88908758
Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents:
2961
diff
changeset

9 
import Data.Word 
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

10 
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

11 
import qualified Data.ByteString.Char8 as B 
4597
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

12 
import Control.DeepSeq 
1804  13 
 
14 
import CoreTypes 

15 
import Actions 

16 
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

17 
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

18 
import RoomsAndClients 
1804  19 

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

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

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

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

27 

1804  28 
handleCmd_lobby :: CmdHandler 
29 

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

30 

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

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

33 
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

34 
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

35 
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

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

37 
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

38 
roomInfo irnc room = [ 
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

39 
showB $ gameinprogress room, 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

40 
name room, 
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

41 
showB $ playersIn room, 
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

42 
showB $ length $ teams room, 
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

43 
nick $ irnc `client` masterID room, 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

44 
head (Map.findWithDefault ["+gen+"] "MAP" (params room)), 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

45 
head (Map.findWithDefault ["Default"] "SCHEME" (params room)), 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

46 
head (Map.findWithDefault ["Default"] "AMMO" (params room)) 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

47 
] 
3501  48 

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

49 

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

51 
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

52 
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

53 
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

54 

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 
handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword] 
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 
 illegalName newRoom = return [Warning "Illegal room name"] 
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 
 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

58 
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

59 
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

60 
return $ if isJust $ find (\room > newRoom == name room) rs 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

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

62 
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

63 
[ 
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 
AddRoom newRoom roomPassword, 
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 
AnswerClients [sendChan cl] ["NOT_READY", nick cl] 
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

66 
] 
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

67 

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

68 

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

69 
handleCmd_lobby ["CREATE_ROOM", newRoom] = 
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

70 
handleCmd_lobby ["CREATE_ROOM", newRoom, ""] 
1804  71 

3536  72 

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 
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = 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

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

75 
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

76 
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

77 
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

78 
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

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

80 
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

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

82 
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

83 
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

84 
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

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

86 
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

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

88 
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

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

90 
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

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

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

93 
AnswerClients [sendChan cl] $ "JOINED" : nicks, 
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4595
diff
changeset

94 
AnswerClients chans ["NOT_READY", 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

95 
] 
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 
++ (map (readynessMessage cl) jRoomClients) 
4587  97 
++ (answerFullConfig cl $ params jRoom) 
4591  98 
++ (answerTeams cl jRoom) 
4595  99 
++ (watchRound cl jRoom) 
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

100 

4587  101 
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

102 
readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c] 
3536  103 

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

106 
answerFullConfig cl params = map (toAnswer cl) (leftConfigPart ++ rightConfigPart) 

107 
where 

108 
(leftConfigPart, rightConfigPart) = partition (\(p, _) > p /= "MAP") $ Map.toList params 

109 

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

4595  112 
watchRound cl jRoom = if not $ gameinprogress jRoom then 
113 
[] 

114 
else 

115 
[AnswerClients [sendChan cl] ["RUN_GAME"], 

116 
AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)] 

117 

3536  118 

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

119 
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

120 
handleCmd_lobby ["JOIN_ROOM", roomName, ""] 
3425  121 

4616  122 

123 
handleCmd_lobby ["FOLLOW", asknick] = do 

124 
(_, rnc) < ask 

125 
ci < clientByNick asknick 

126 
let ri = clientRoom rnc $ fromJust ci 

127 
let clRoom = room rnc ri 

128 
if isNothing ci  ri == lobbyId then 

129 
return [] 

130 
else 

131 
handleCmd_lobby ["JOIN_ROOM", name clRoom] 

132 

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

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

134 
 Administrator's stuff  
1862  135 

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

138 
cl < thisClient 

139 
kickId < clientByNick kickNick 

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

1866  141 

4618  142 
{ 
1866  143 
handleCmd_lobby clID clients rooms ["BAN", banNick] = 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

144 
if not $ isAdministrator client then 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

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

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

147 
BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick] 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

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

149 
client = clients IntMap.! clID 
4620  150 
} 
1804  151 

3283  152 

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

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

1925  156 

4620  157 
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do 
158 
cl < thisClient 

159 
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

160 

4620  161 
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do 
162 
cl < thisClient 

163 
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

164 
where 
4620  165 
readNum = case B.readInt protoNum of 
166 
Just (i, t)  B.null t > fromIntegral i 

167 
otherwise > 0 

1925  168 

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

171 
return [SendServerVars  isAdministrator cl] 

3283  172 

4620  173 
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do 
174 
cl < thisClient 

175 
return [ClearAccountsCache  isAdministrator cl] 

2155
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2150
diff
changeset

176 

d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2150
diff
changeset

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)"] 