author | unc0rr |
Wed, 08 Oct 2008 18:38:54 +0000 | |
changeset 1323 | d166f9069c2b |
parent 1322 | c624b04699fb |
child 1325 | c8994d47f41d |
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"])] |
1307 | 33 |
|
1082 | 34 |
-- Main state-independent cmd handler |
35 |
handleCmd :: CmdHandler |
|
36 |
handleCmd client _ rooms ("QUIT":xs) = |
|
37 |
if null (room client) then |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
38 |
(noChangeClients, noChangeRooms, answerQuit) |
1082 | 39 |
else if isMaster client then |
1308
d5dcd6cfa5e2
Fix another server failure (when second client in room disconnects)
unc0rr
parents:
1307
diff
changeset
|
40 |
(noChangeClients, removeRoom (room client), answerAbandoned) -- core disconnects clients on ROOMABANDONED answer |
1082 | 41 |
else |
1309 | 42 |
(noChangeClients, noChangeRooms, answerQuit ++ (answerQuitInform $ nick client)) |
895 | 43 |
|
1307 | 44 |
|
1082 | 45 |
-- check state and call state-dependent commmand handlers |
46 |
handleCmd client clients rooms cmd = |
|
47 |
if null (nick client) || protocol client == 0 then |
|
48 |
handleCmd_noInfo client clients rooms cmd |
|
49 |
else if null (room client) then |
|
50 |
handleCmd_noRoom client clients rooms cmd |
|
51 |
else |
|
52 |
handleCmd_inRoom client clients rooms cmd |
|
53 |
||
1307 | 54 |
|
1082 | 55 |
-- 'no info' state - need to get protocol number and nickname |
56 |
handleCmd_noInfo :: CmdHandler |
|
57 |
handleCmd_noInfo client clients _ ["NICK", newNick] = |
|
894 | 58 |
if not . null $ nick client then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
59 |
(noChangeClients, noChangeRooms, answerNickChosen) |
894 | 60 |
else if haveSameNick then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
61 |
(noChangeClients, noChangeRooms, answerNickChooseAnother) |
894 | 62 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
63 |
(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick) |
894 | 64 |
where |
1320 | 65 |
haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients |
894 | 66 |
|
1082 | 67 |
handleCmd_noInfo client _ _ ["PROTO", protoNum] = |
894 | 68 |
if protocol client > 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
69 |
(noChangeClients, noChangeRooms, answerProtocolKnown) |
894 | 70 |
else if parsedProto == 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
71 |
(noChangeClients, noChangeRooms, answerBadInput) |
894 | 72 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
73 |
(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto) |
894 | 74 |
where |
75 |
parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) |
|
76 |
||
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
77 |
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
894 | 78 |
|
1307 | 79 |
|
894 | 80 |
-- 'noRoom' clients state command handlers |
1082 | 81 |
handleCmd_noRoom :: CmdHandler |
82 |
handleCmd_noRoom client _ rooms ["LIST"] = |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
83 |
(noChangeClients, noChangeRooms, answerRoomsList $ map name rooms) |
903 | 84 |
|
1082 | 85 |
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = |
895 | 86 |
if haveSameRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
87 |
(noChangeClients, noChangeRooms, answerRoomExists) |
895 | 88 |
else |
1317 | 89 |
(modifyClient client{room = newRoom, isMaster = True}, addRoom (RoomInfo newRoom roomPassword (protocol client) [] Map.empty), answerJoined $ nick client) |
895 | 90 |
where |
1320 | 91 |
haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms |
895 | 92 |
|
1082 | 93 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom] = |
94 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] |
|
95 |
||
1308
d5dcd6cfa5e2
Fix another server failure (when second client in room disconnects)
unc0rr
parents:
1307
diff
changeset
|
96 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] = |
902 | 97 |
if noSuchRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
98 |
(noChangeClients, noChangeRooms, answerNoRoom) |
1321 | 99 |
else if roomPassword /= password clRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
100 |
(noChangeClients, noChangeRooms, answerWrongPassword) |
895 | 101 |
else |
1321 | 102 |
(modifyClient client{room = roomName}, noChangeRooms, (answerJoined $ nick client) ++ answerNicks ++ answerFullConfig clRoom) |
895 | 103 |
where |
1320 | 104 |
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
|
105 |
answerNicks = [(clientOnly, ["JOINED"] ++ (map nick $ filter (\ci -> room ci == roomName) clients))] |
1321 | 106 |
clRoom = roomByName roomName rooms |
895 | 107 |
|
1082 | 108 |
handleCmd_noRoom client clients rooms ["JOIN", roomName] = |
109 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] |
|
894 | 110 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
111 |
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
895 | 112 |
|
1307 | 113 |
|
897 | 114 |
-- 'inRoom' clients state command handlers |
1082 | 115 |
handleCmd_inRoom :: CmdHandler |
1322
c624b04699fb
Fix protocol implementation to conform documentation
unc0rr
parents:
1321
diff
changeset
|
116 |
handleCmd_inRoom client _ _ ["CHAT_STRING", msg] = |
1317 | 117 |
(noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
897 | 118 |
|
1321 | 119 |
handleCmd_inRoom client _ rooms ("CONFIG_PARAM":paramName:paramStrs) = |
1317 | 120 |
if isMaster client then |
1322
c624b04699fb
Fix protocol implementation to conform documentation
unc0rr
parents:
1321
diff
changeset
|
121 |
(noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs) |
1317 | 122 |
else |
123 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
1321 | 124 |
where |
125 |
clRoom = roomByName (room client) rooms |
|
126 |
||
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
|
127 |
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
|
128 |
| 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
|
129 |
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
|
130 |
(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
|
131 |
else |
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 |
(noChangeClients, modifyRoom clRoom{teams = newTeam : teams clRoom}, []) |
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 |
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
|
134 |
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
|
135 |
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
|
136 |
difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) |
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 |
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
|
138 |
|
1083 | 139 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
140 |
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |