author | unc0rr |
Mon, 06 Oct 2008 18:07:38 +0000 | |
changeset 1307 | ce26e16d18ab |
parent 1305 | 453882eb4467 |
child 1308 | d5dcd6cfa5e2 |
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 |
|
1307 | 26 |
|
1082 | 27 |
-- Main state-independent cmd handler |
28 |
handleCmd :: CmdHandler |
|
29 |
handleCmd client _ rooms ("QUIT":xs) = |
|
30 |
if null (room client) then |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
31 |
(noChangeClients, noChangeRooms, answerQuit) |
1082 | 32 |
else if isMaster client then |
1307 | 33 |
(noChangeClients, removeRoom (room client), answerAbandoned ++ (answerQuitInform $ nick client)) -- core disconnects clients on ROOMABANDONED answer |
1082 | 34 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
35 |
(noChangeClients, noChangeRooms, answerQuitInform $ nick client) |
895 | 36 |
|
1307 | 37 |
|
1082 | 38 |
-- check state and call state-dependent commmand handlers |
39 |
handleCmd client clients rooms cmd = |
|
40 |
if null (nick client) || protocol client == 0 then |
|
41 |
handleCmd_noInfo client clients rooms cmd |
|
42 |
else if null (room client) then |
|
43 |
handleCmd_noRoom client clients rooms cmd |
|
44 |
else |
|
45 |
handleCmd_inRoom client clients rooms cmd |
|
46 |
||
1307 | 47 |
|
1082 | 48 |
-- 'no info' state - need to get protocol number and nickname |
49 |
handleCmd_noInfo :: CmdHandler |
|
50 |
handleCmd_noInfo client clients _ ["NICK", newNick] = |
|
894 | 51 |
if not . null $ nick client then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
52 |
(noChangeClients, noChangeRooms, answerNickChosen) |
894 | 53 |
else if haveSameNick then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
54 |
(noChangeClients, noChangeRooms, answerNickChooseAnother) |
894 | 55 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
56 |
(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick) |
894 | 57 |
where |
58 |
haveSameNick = not . null $ filter (\cl -> newNick == nick cl) clients |
|
59 |
||
1082 | 60 |
handleCmd_noInfo client _ _ ["PROTO", protoNum] = |
894 | 61 |
if protocol client > 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
62 |
(noChangeClients, noChangeRooms, answerProtocolKnown) |
894 | 63 |
else if parsedProto == 0 then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
64 |
(noChangeClients, noChangeRooms, answerBadInput) |
894 | 65 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
66 |
(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto) |
894 | 67 |
where |
68 |
parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) |
|
69 |
||
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
70 |
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
894 | 71 |
|
1307 | 72 |
|
894 | 73 |
-- 'noRoom' clients state command handlers |
1082 | 74 |
handleCmd_noRoom :: CmdHandler |
75 |
handleCmd_noRoom client _ rooms ["LIST"] = |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
76 |
(noChangeClients, noChangeRooms, answerRoomsList $ map name rooms) |
903 | 77 |
|
1082 | 78 |
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = |
895 | 79 |
if haveSameRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
80 |
(noChangeClients, noChangeRooms, answerRoomExists) |
895 | 81 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
82 |
(modifyClient client{room = newRoom, isMaster = True}, addRoom (RoomInfo newRoom roomPassword []), answerJoined $ nick client) |
895 | 83 |
where |
84 |
haveSameRoom = not . null $ filter (\room -> newRoom == name room) rooms |
|
85 |
||
1082 | 86 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom] = |
87 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] |
|
88 |
||
89 |
handleCmd_noRoom client _ rooms ["JOIN", roomName, roomPassword] = |
|
902 | 90 |
if noSuchRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
91 |
(noChangeClients, noChangeRooms, answerNoRoom) |
902 | 92 |
else if roomPassword /= password (roomByName roomName rooms) then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
93 |
(noChangeClients, noChangeRooms, answerWrongPassword) |
895 | 94 |
else |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
95 |
(modifyClient client{room = roomName}, noChangeRooms, answerJoined $ nick client) |
895 | 96 |
where |
902 | 97 |
noSuchRoom = null $ filter (\room -> roomName == name room) rooms |
895 | 98 |
|
1082 | 99 |
handleCmd_noRoom client clients rooms ["JOIN", roomName] = |
100 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] |
|
894 | 101 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
102 |
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
895 | 103 |
|
1307 | 104 |
|
897 | 105 |
-- 'inRoom' clients state command handlers |
1082 | 106 |
handleCmd_inRoom :: CmdHandler |
897 | 107 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
108 |
handleCmd_inRoom client _ _ ["CHAT_STRING", _, msg] = (noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
1083 | 109 |
|
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
110 |
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |