13 |
13 |
14 teamToNet team = ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo |
14 teamToNet team = ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo |
15 where |
15 where |
16 hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
16 hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
17 |
17 |
18 answerServerMessage clients = [(clientOnly, "SERVER_MESSAGE" : [mainbody ++ clientsIn])] |
18 makeAnswer :: HandlesSelector -> [String] -> [Answer] |
|
19 makeAnswer func msg = [(func, msg)]-- [\_ -> (func, msg)] |
|
20 answerClientOnly, answerOthersRoom, answerSameRoom :: [String] -> [Answer] |
|
21 answerClientOnly = makeAnswer clientOnly |
|
22 answerOthersRoom = makeAnswer othersInRoom |
|
23 answerSameRoom = makeAnswer sameRoom |
|
24 |
|
25 answerBadCmd = answerClientOnly ["ERROR", "Bad command, state or incorrect parameter"] |
|
26 answerNotMaster = answerClientOnly ["ERROR", "You cannot configure room parameters"] |
|
27 answerBadParam = answerClientOnly ["ERROR", "Bad parameter"] |
|
28 answerErrorMsg msg = answerClientOnly ["ERROR", msg] |
|
29 answerQuit msg = answerClientOnly ["BYE", msg] |
|
30 answerNickChosen = answerClientOnly ["ERROR", "The nick already chosen"] |
|
31 answerNickChooseAnother = answerClientOnly ["WARNING", "Choose another nick"] |
|
32 answerNick nick = answerClientOnly ["NICK", nick] |
|
33 answerProtocolKnown = answerClientOnly ["ERROR", "Protocol number already known"] |
|
34 answerBadInput = answerClientOnly ["ERROR", "Bad input"] |
|
35 answerProto protoNum = answerClientOnly ["PROTO", show protoNum] |
|
36 answerRoomsList list = answerClientOnly $ "ROOMS" : list |
|
37 answerRoomExists = answerClientOnly ["WARNING", "There's already a room with that name"] |
|
38 answerNoRoom = answerClientOnly ["WARNING", "There's no room with that name"] |
|
39 answerWrongPassword = answerClientOnly ["WARNING", "Wrong password"] |
|
40 answerCantAdd reason = answerClientOnly ["WARNING", "Cannot add team: " ++ reason] |
|
41 answerTeamAccepted team = answerClientOnly ["TEAM_ACCEPTED", teamname team] |
|
42 answerTooFewClans = answerClientOnly ["ERROR", "Too few clans in game"] |
|
43 answerRestricted = answerClientOnly ["WARNING", "Room joining restricted"] |
|
44 answerConnected = answerClientOnly ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
|
45 answerNotOwner = answerClientOnly ["ERROR", "You do not own this team"] |
|
46 answerCannotCreateRoom = answerClientOnly ["WARNING", "Cannot create more rooms"] |
|
47 |
|
48 answerAbandoned = answerOthersRoom ["BYE", "Room abandoned"] |
|
49 answerQuitInform nick = answerOthersRoom ["LEFT", nick] |
|
50 answerChatString nick msg = answerOthersRoom ["CHAT_STRING", nick, msg] |
|
51 answerAddTeam team = answerOthersRoom $ teamToNet team |
|
52 answerRemoveTeam teamName = answerOthersRoom ["REMOVE_TEAM", teamName] |
|
53 answerMap mapName = answerOthersRoom ["MAP", mapName] |
|
54 answerHHNum teamName hhNumber = answerOthersRoom ["HH_NUM", teamName, show hhNumber] |
|
55 answerTeamColor teamName newColor = answerOthersRoom ["TEAM_COLOR", teamName, newColor] |
|
56 answerConfigParam paramName paramStrs = answerOthersRoom $ "CONFIG_PARAM" : paramName : paramStrs |
|
57 |
|
58 answerJoined nick = answerSameRoom ["JOINED", nick] |
|
59 answerRunGame = answerSameRoom ["RUN_GAME"] |
|
60 answerIsReady nick = answerSameRoom ["READY", nick] |
|
61 answerNotReady nick = answerSameRoom ["NOT_READY", nick] |
|
62 |
|
63 answerFullConfig room = concatMap toAnswer (Map.toList $ params room) ++ (answerClientOnly ["MAP", gamemap room]) |
|
64 where |
|
65 toAnswer (paramName, paramStrs) = |
|
66 answerClientOnly $ "CONFIG_PARAM" : paramName : paramStrs |
|
67 |
|
68 answerAllTeams room = concatMap toAnswer (teams room) |
|
69 where |
|
70 toAnswer team = |
|
71 (answerClientOnly $ teamToNet team) ++ |
|
72 (answerClientOnly ["TEAM_COLOR", teamname team, teamcolor team]) ++ |
|
73 (answerClientOnly ["HH_NUM", teamname team, show $ hhnum team]) |
|
74 |
|
75 answerServerMessage clients = answerClientOnly $ "SERVER_MESSAGE" : [mainbody ++ clientsIn] |
19 where |
76 where |
20 mainbody = serverMessage globalOptions ++ if isDedicated globalOptions then "<p align=center>Dedicated server</p>" else "<p align=center>Private server</p>" |
77 mainbody = serverMessage globalOptions ++ if isDedicated globalOptions then "<p align=center>Dedicated server</p>" else "<p align=center>Private server</p>" |
21 clientsIn = "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>" |
78 clientsIn = "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>" |
22 clientslist = if not $ null nicks then foldr1 (\a b -> a ++ ", " ++ b) nicks else "" |
79 clientslist = if not $ null nicks then foldr1 (\a b -> a ++ ", " ++ b) nicks else "" |
23 nicks = filter (not . null) $ map nick clients |
80 nicks = filter (not . null) $ map nick clients |
24 |
81 answerPing = makeAnswer allClients ["PING"] |
25 answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])] |
82 |
26 answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])] |
|
27 answerBadParam = [(clientOnly, ["ERROR", "Bad parameter"])] |
|
28 answerErrorMsg msg = [(clientOnly, ["ERROR", msg])] |
|
29 answerQuit msg = [(clientOnly, ["BYE", msg])] |
|
30 answerAbandoned = [(othersInRoom, ["BYE", "Room abandoned"])] |
|
31 answerQuitInform nick = [(othersInRoom, ["LEFT", nick])] |
|
32 answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])] |
|
33 answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])] |
|
34 answerNick nick = [(clientOnly, ["NICK", nick])] |
|
35 answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])] |
|
36 answerBadInput = [(clientOnly, ["ERROR", "Bad input"])] |
|
37 answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])] |
|
38 answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)] |
|
39 answerRoomExists = [(clientOnly, ["WARNING", "There's already a room with that name"])] |
|
40 answerJoined nick = [(sameRoom, ["JOINED", nick])] |
|
41 answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])] |
|
42 answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])] |
|
43 answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])] |
|
44 answerConfigParam paramName paramStrs = [(othersInRoom, "CONFIG_PARAM" : paramName : paramStrs)] |
|
45 answerFullConfig room = map toAnswer (Map.toList $ params room) ++ [(clientOnly, ["MAP", gamemap room])] |
|
46 where |
|
47 toAnswer (paramName, paramStrs) = |
|
48 (clientOnly, "CONFIG_PARAM" : paramName : paramStrs) |
|
49 answerCantAdd reason = [(clientOnly, ["WARNING", "Cannot add team: " ++ reason])] |
|
50 answerTeamAccepted team = [(clientOnly, ["TEAM_ACCEPTED", teamname team])] |
|
51 answerAddTeam team = [(othersInRoom, teamToNet team)] |
|
52 answerHHNum teamName hhNumber = [(othersInRoom, ["HH_NUM", teamName, show hhNumber])] |
|
53 answerRemoveTeam teamName = [(othersInRoom, ["REMOVE_TEAM", teamName])] |
|
54 answerNotOwner = [(clientOnly, ["ERROR", "You do not own this team"])] |
|
55 answerTeamColor teamName newColor = [(othersInRoom, ["TEAM_COLOR", teamName, newColor])] |
|
56 answerAllTeams room = concatMap toAnswer (teams room) |
|
57 where |
|
58 toAnswer team = |
|
59 [(clientOnly, teamToNet team), |
|
60 (clientOnly, ["TEAM_COLOR", teamname team, teamcolor team]), |
|
61 (clientOnly, ["HH_NUM", teamname team, show $ hhnum team])] |
|
62 answerMap mapName = [(othersInRoom, ["MAP", mapName])] |
|
63 answerRunGame = [(sameRoom, ["RUN_GAME"])] |
|
64 answerCannotCreateRoom = [(clientOnly, ["WARNING", "Cannot create more rooms"])] |
|
65 answerIsReady nick = [(sameRoom, ["READY", nick])] |
|
66 answerNotReady nick = [(sameRoom, ["NOT_READY", nick])] |
|
67 answerTooFewClans = [(clientOnly, ["ERROR", "Too few clans in game"])] |
|
68 answerRestricted = [(clientOnly, ["WARNING", "Room joining restricted"])] |
|
69 answerPing = [(allClients, ["PING"])] |
|
70 answerConnected = [(clientOnly, ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])] |
|
71 |
83 |
72 -- Main state-independent cmd handler |
84 -- Main state-independent cmd handler |
73 handleCmd :: CmdHandler |
85 handleCmd :: CmdHandler |
74 handleCmd client _ rooms ("QUIT" : xs) = |
86 handleCmd client _ rooms ("QUIT" : xs) = |
75 if null (room client) then |
87 if null (room client) then |