author | unc0rr |
Sun, 05 Oct 2008 23:36:11 +0000 | |
changeset 1306 | e848447f29be |
parent 1305 | 453882eb4467 |
child 1307 | ce26e16d18ab |
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 |
896 | 7 |
import Maybe (fromMaybe, fromJust) |
890 | 8 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
9 |
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])] |
1305 | 10 |
answerQuit = [(clientOnly, ["BYE"])] |
11 |
answerAbandoned = [(sameRoom, ["BYE"])] |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
12 |
answerQuitInform nick = [(sameRoom, ["QUIT", nick])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
13 |
answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
14 |
answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
15 |
answerNick nick = [(clientOnly, ["NICK", nick])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
16 |
answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
17 |
answerBadInput = [(clientOnly, ["ERROR", "Bad input"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
18 |
answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
19 |
answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
20 |
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
|
21 |
answerJoined nick = [(sameRoom, ["JOINED", nick])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
22 |
answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
23 |
answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
24 |
answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])] |
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
25 |
|
1082 | 26 |
-- Main state-independent cmd handler |
27 |
handleCmd :: CmdHandler |
|
28 |
handleCmd client _ rooms ("QUIT":xs) = |
|
29 |
if null (room client) then |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
30 |
(noChangeClients, noChangeRooms, answerQuit) |
1082 | 31 |
else if isMaster client then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
32 |
(noChangeClients, removeRoom (room client), (answerQuitInform $ nick client) ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer |
1082 | 33 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
34 |
(noChangeClients, noChangeRooms, answerQuitInform $ nick client) |
895 | 35 |
|
1082 | 36 |
-- check state and call state-dependent commmand handlers |
37 |
handleCmd client clients rooms cmd = |
|
38 |
if null (nick client) || protocol client == 0 then |
|
39 |
handleCmd_noInfo client clients rooms cmd |
|
40 |
else if null (room client) then |
|
41 |
handleCmd_noRoom client clients rooms cmd |
|
42 |
else |
|
43 |
handleCmd_inRoom client clients rooms cmd |
|
44 |
||
45 |
-- 'no info' state - need to get protocol number and nickname |
|
46 |
handleCmd_noInfo :: CmdHandler |
|
47 |
handleCmd_noInfo client clients _ ["NICK", newNick] = |
|
894 | 48 |
if not . null $ nick client then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
49 |
(noChangeClients, noChangeRooms, answerNickChosen) |
894 | 50 |
else if haveSameNick then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
51 |
(noChangeClients, noChangeRooms, answerNickChooseAnother) |
894 | 52 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
53 |
(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick) |
894 | 54 |
where |
55 |
haveSameNick = not . null $ filter (\cl -> newNick == nick cl) clients |
|
56 |
||
1082 | 57 |
handleCmd_noInfo client _ _ ["PROTO", protoNum] = |
894 | 58 |
if protocol client > 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
59 |
(noChangeClients, noChangeRooms, answerProtocolKnown) |
894 | 60 |
else if parsedProto == 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
61 |
(noChangeClients, noChangeRooms, answerBadInput) |
894 | 62 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
63 |
(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto) |
894 | 64 |
where |
65 |
parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) |
|
66 |
||
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
67 |
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
894 | 68 |
|
69 |
-- 'noRoom' clients state command handlers |
|
1082 | 70 |
handleCmd_noRoom :: CmdHandler |
71 |
handleCmd_noRoom client _ rooms ["LIST"] = |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
72 |
(noChangeClients, noChangeRooms, answerRoomsList $ map name rooms) |
903 | 73 |
|
1082 | 74 |
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = |
895 | 75 |
if haveSameRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
76 |
(noChangeClients, noChangeRooms, answerRoomExists) |
895 | 77 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
78 |
(modifyClient client{room = newRoom, isMaster = True}, addRoom (RoomInfo newRoom roomPassword []), answerJoined $ nick client) |
895 | 79 |
where |
80 |
haveSameRoom = not . null $ filter (\room -> newRoom == name room) rooms |
|
81 |
||
1082 | 82 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom] = |
83 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] |
|
84 |
||
85 |
handleCmd_noRoom client _ rooms ["JOIN", roomName, roomPassword] = |
|
902 | 86 |
if noSuchRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
87 |
(noChangeClients, noChangeRooms, answerNoRoom) |
902 | 88 |
else if roomPassword /= password (roomByName roomName rooms) then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
89 |
(noChangeClients, noChangeRooms, answerWrongPassword) |
895 | 90 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
91 |
(modifyClient client{room = roomName}, noChangeRooms, answerJoined $ nick client) |
895 | 92 |
where |
902 | 93 |
noSuchRoom = null $ filter (\room -> roomName == name room) rooms |
895 | 94 |
|
1082 | 95 |
handleCmd_noRoom client clients rooms ["JOIN", roomName] = |
96 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] |
|
894 | 97 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
98 |
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
895 | 99 |
|
897 | 100 |
-- 'inRoom' clients state command handlers |
1082 | 101 |
handleCmd_inRoom :: CmdHandler |
897 | 102 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
103 |
handleCmd_inRoom client _ _ ["CHAT_STRING", _, msg] = (noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
1083 | 104 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
105 |
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |