author  unc0rr 
Wed, 02 Feb 2011 22:19:10 +0300  
changeset 4909  dc6482438674 
parent 4904  0eab727d4717 
child 4914  5c33bb53c1e5 
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]] 

4568  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 
] 
1804  67 

3536  68 

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

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, ""] 
3536  71 

1862  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) 
1804  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 
1813  105 

4587  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 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2408
diff
changeset

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

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

1813  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, ""] 
4568  121 

1804  122 

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

1862  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 

4909  142 

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

144 
(ci, _) < ask 

145 
cl < thisClient 

146 
banId < clientByNick banNick 

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

1804  148 

3283  149 

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

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

1925  153 

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

156 
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

157 

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

160 
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

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

164 
otherwise > 0 

1925  165 

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

168 
return [SendServerVars  isAdministrator cl] 

3283  169 

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

172 
return [ClearAccountsCache  isAdministrator cl] 

3283  173 

174 

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

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