author | unc0rr |
Wed, 08 Oct 2008 18:56:32 +0000 | |
changeset 1325 | c8994d47f41d |
parent 1323 | d166f9069c2b |
child 1327 | 9d43a6e6b9ca |
permissions | -rw-r--r-- |
890 | 1 |
module HWProto where |
2 |
||
3 |
import IO |
|
896 | 4 |
import Data.List |
894 | 5 |
import Data.Word |
890 | 6 |
import Miscutils |
1320 | 7 |
import Maybe |
1317 | 8 |
import qualified Data.Map as Map |
890 | 9 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
10 |
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])] |
1317 | 11 |
answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])] |
1309 | 12 |
answerQuit = [(clientOnly, ["off"])] |
1305 | 13 |
answerAbandoned = [(sameRoom, ["BYE"])] |
1309 | 14 |
answerQuitInform nick = [(othersInRoom, ["LEFT", nick])] |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
15 |
answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
16 |
answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
17 |
answerNick nick = [(clientOnly, ["NICK", nick])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
18 |
answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
19 |
answerBadInput = [(clientOnly, ["ERROR", "Bad input"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
20 |
answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
21 |
answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
22 |
answerRoomExists = [(clientOnly, ["WARNING", "There's already a room with that name"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
23 |
answerJoined nick = [(sameRoom, ["JOINED", nick])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
24 |
answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
25 |
answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
26 |
answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])] |
1317 | 27 |
answerConfigParam paramName paramStrs = [(othersInRoom, "CONFIG_PARAM" : paramName : paramStrs)] |
28 |
answerFullConfig room = map toAnswer (Map.toList $ params room) |
|
29 |
where |
|
1321 | 30 |
toAnswer (paramName, paramStrs) = |
1317 | 31 |
(clientOnly, "CONFIG_PARAM" : paramName : paramStrs) |
1323
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
32 |
answerCantAdd = [(clientOnly, ["WARNING", "Too many teams"])] |
1325 | 33 |
answerTeamAccepted team = [(clientOnly, ["TEAM_ACCEPTED", teamname team])] |
34 |
answerAddTeam team = [(othersInRoom, ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo)] |
|
35 |
where |
|
36 |
hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
|
1307 | 37 |
|
1082 | 38 |
-- Main state-independent cmd handler |
39 |
handleCmd :: CmdHandler |
|
40 |
handleCmd client _ rooms ("QUIT":xs) = |
|
41 |
if null (room client) then |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
42 |
(noChangeClients, noChangeRooms, answerQuit) |
1082 | 43 |
else if isMaster client then |
1308
d5dcd6cfa5e2
Fix another server failure (when second client in room disconnects)
unc0rr
parents:
1307
diff
changeset
|
44 |
(noChangeClients, removeRoom (room client), answerAbandoned) -- core disconnects clients on ROOMABANDONED answer |
1082 | 45 |
else |
1309 | 46 |
(noChangeClients, noChangeRooms, answerQuit ++ (answerQuitInform $ nick client)) |
895 | 47 |
|
1307 | 48 |
|
1082 | 49 |
-- check state and call state-dependent commmand handlers |
50 |
handleCmd client clients rooms cmd = |
|
51 |
if null (nick client) || protocol client == 0 then |
|
52 |
handleCmd_noInfo client clients rooms cmd |
|
53 |
else if null (room client) then |
|
54 |
handleCmd_noRoom client clients rooms cmd |
|
55 |
else |
|
56 |
handleCmd_inRoom client clients rooms cmd |
|
57 |
||
1307 | 58 |
|
1082 | 59 |
-- 'no info' state - need to get protocol number and nickname |
60 |
handleCmd_noInfo :: CmdHandler |
|
61 |
handleCmd_noInfo client clients _ ["NICK", newNick] = |
|
894 | 62 |
if not . null $ nick client then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
63 |
(noChangeClients, noChangeRooms, answerNickChosen) |
894 | 64 |
else if haveSameNick then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
65 |
(noChangeClients, noChangeRooms, answerNickChooseAnother) |
894 | 66 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
67 |
(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick) |
894 | 68 |
where |
1320 | 69 |
haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients |
894 | 70 |
|
1082 | 71 |
handleCmd_noInfo client _ _ ["PROTO", protoNum] = |
894 | 72 |
if protocol client > 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
73 |
(noChangeClients, noChangeRooms, answerProtocolKnown) |
894 | 74 |
else if parsedProto == 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
75 |
(noChangeClients, noChangeRooms, answerBadInput) |
894 | 76 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
77 |
(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto) |
894 | 78 |
where |
79 |
parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) |
|
80 |
||
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
81 |
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
894 | 82 |
|
1307 | 83 |
|
894 | 84 |
-- 'noRoom' clients state command handlers |
1082 | 85 |
handleCmd_noRoom :: CmdHandler |
86 |
handleCmd_noRoom client _ rooms ["LIST"] = |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
87 |
(noChangeClients, noChangeRooms, answerRoomsList $ map name rooms) |
903 | 88 |
|
1082 | 89 |
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = |
895 | 90 |
if haveSameRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
91 |
(noChangeClients, noChangeRooms, answerRoomExists) |
895 | 92 |
else |
1317 | 93 |
(modifyClient client{room = newRoom, isMaster = True}, addRoom (RoomInfo newRoom roomPassword (protocol client) [] Map.empty), answerJoined $ nick client) |
895 | 94 |
where |
1320 | 95 |
haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms |
895 | 96 |
|
1082 | 97 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom] = |
98 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] |
|
99 |
||
1308
d5dcd6cfa5e2
Fix another server failure (when second client in room disconnects)
unc0rr
parents:
1307
diff
changeset
|
100 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] = |
902 | 101 |
if noSuchRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
102 |
(noChangeClients, noChangeRooms, answerNoRoom) |
1321 | 103 |
else if roomPassword /= password clRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
104 |
(noChangeClients, noChangeRooms, answerWrongPassword) |
895 | 105 |
else |
1321 | 106 |
(modifyClient client{room = roomName}, noChangeRooms, (answerJoined $ nick client) ++ answerNicks ++ answerFullConfig clRoom) |
895 | 107 |
where |
1320 | 108 |
noSuchRoom = isNothing $ find (\room -> roomName == name room) rooms |
1308
d5dcd6cfa5e2
Fix another server failure (when second client in room disconnects)
unc0rr
parents:
1307
diff
changeset
|
109 |
answerNicks = [(clientOnly, ["JOINED"] ++ (map nick $ filter (\ci -> room ci == roomName) clients))] |
1321 | 110 |
clRoom = roomByName roomName rooms |
895 | 111 |
|
1082 | 112 |
handleCmd_noRoom client clients rooms ["JOIN", roomName] = |
113 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] |
|
894 | 114 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
115 |
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
895 | 116 |
|
1307 | 117 |
|
897 | 118 |
-- 'inRoom' clients state command handlers |
1082 | 119 |
handleCmd_inRoom :: CmdHandler |
1322
c624b04699fb
Fix protocol implementation to conform documentation
unc0rr
parents:
1321
diff
changeset
|
120 |
handleCmd_inRoom client _ _ ["CHAT_STRING", msg] = |
1317 | 121 |
(noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
897 | 122 |
|
1321 | 123 |
handleCmd_inRoom client _ rooms ("CONFIG_PARAM":paramName:paramStrs) = |
1317 | 124 |
if isMaster client then |
1322
c624b04699fb
Fix protocol implementation to conform documentation
unc0rr
parents:
1321
diff
changeset
|
125 |
(noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs) |
1317 | 126 |
else |
127 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
1321 | 128 |
where |
129 |
clRoom = roomByName (room client) rooms |
|
130 |
||
1323
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
131 |
handleCmd_inRoom client _ rooms ("ADDTEAM" : name : color : grave : fort : difStr : hhsInfo) |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
132 |
| length hhsInfo == 16 = |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
133 |
if length (teams clRoom) == 6 then |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
134 |
(noChangeClients, noChangeRooms, answerCantAdd) |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
135 |
else |
1325 | 136 |
(noChangeClients, modifyRoom clRoom{teams = newTeam : teams clRoom}, answerTeamAccepted newTeam ++ answerAddTeam newTeam) |
1323
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
137 |
where |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
138 |
clRoom = roomByName (room client) rooms |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
139 |
newTeam = (TeamInfo name color grave fort difficulty (hhsList hhsInfo)) |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
140 |
difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) |
1325 | 141 |
hhsList [] = [] |
1323
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
142 |
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs |
d166f9069c2b
Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents:
1322
diff
changeset
|
143 |
|
1083 | 144 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
145 |
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |