Dedicated server
" - else - "Private server
" - - updateInfo = if protocol client < 23 then "" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "
" else [] - clientslist = if not $ null nicks then foldr1 (\a b -> a ++ ", " ++ b) nicks else "" - lastHour serverInfo = - if isDedicated serverInfo then - "" ++ (show $ length $ lastHourUsers serverInfo) ++ " user logins in last hour
" - else - "" - nicks = filter (not . null) $ map nick clients - -answerPing = makeAnswer allClients ["PING"] - --- Main state-independent cmd handler -handleCmd :: CmdHandler -handleCmd client _ rooms ("QUIT" : xs) = - if null (room client) then - (noChangeClients, noChangeRooms, answerQuit msg ++ (answerQuitLobby (nick client) msg) ) - else if isMaster client then - (modifyRoomClients clRoom (\cl -> cl{isReady = False, partRoom = True}), removeRoom (room client), (answerQuit msg) ++ (answerQuitLobby (nick client) msg) ++ (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client)) -- core disconnects clients on ROOMABANDONED answer - else - if not $ gameinprogress clRoom then - (noChangeClients, - modifyRoom clRoom{ - teams = othersTeams, - playersIn = (playersIn clRoom) - 1, - readyPlayers = newReadyPlayers - }, - (answerQuit msg) ++ - (answerQuitInform (nick client) msg) ++ - (answerQuitLobby (nick client) msg) ++ - answerRemoveClientTeams) - else - (noChangeClients, - modifyRoom clRoom{ - teams = othersTeams, - leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom), - roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs), - playersIn = (playersIn clRoom) - 1, - readyPlayers = newReadyPlayers - }, - (answerQuit msg) ++ - (answerQuitInform (nick client) msg) ++ - (answerQuitLobby (nick client) msg) ++ - answerRemoveClientTeams ++ - answerEngineTeamsRemoveMsg) - where - clRoom = roomByName (room client) rooms - answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams - (clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom - newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom - msg = if not $ null xs then head xs else "" - rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams - answerEngineTeamsRemoveMsg = - if not $ null rmTeamsMsgs then - answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs - else - [] - -handleCmd _ _ _ ["PING"] = -- core requsted - (noChangeClients, noChangeRooms, answerPing) - -handleCmd _ _ _ ["ASKME"] = -- core requsted - (noChangeClients, noChangeRooms, answerConnected) - -handleCmd _ _ _ ["PONG"] = - (noChangeClients, noChangeRooms, []) - -handleCmd _ _ _ ["ERROR", msg] = - (noChangeClients, noChangeRooms, answerErrorMsg msg) - -handleCmd _ clients _ ["INFO", asknick] = - if noSuchClient then - (noChangeClients, noChangeRooms, []) - else - (noChangeClients, noChangeRooms, answerInfo client) - where - maybeClient = find (\cl -> asknick == nick cl) clients - noSuchClient = isNothing maybeClient - client = fromJust maybeClient - - --- check state and call state-dependent commmand handlers -handleCmd client clients rooms cmd = - if null (nick client) || protocol client == 0 then - handleCmd_noInfo client clients rooms cmd - else if null (room client) then - handleCmd_noRoom client clients rooms cmd - else - handleCmd_inRoom client clients rooms cmd - - --- 'no info' state - need to get protocol number and nickname -onLoginFinished client clients = - if (null $ nick client) || (protocol client == 0) then - [] - else - answerLobbyNicks ++ - (answerAll ["LOBBY:JOINED", nick client]) ++ - (answerServerMessage client clients) - where - lobbyNicks = filter (\n -> (not (null n)) && n /= nick client) $ map nick $ clients - answerLobbyNicks = if not $ null lobbyNicks then - answerClientOnly $ ["LOBBY:JOINED"] ++ lobbyNicks - else - [] - -handleCmd_noInfo :: CmdHandler -handleCmd_noInfo client clients _ ["NICK", newNick] = - if not . null $ nick client then - (noChangeClients, noChangeRooms, answerNickChosen) - else if haveSameNick then - (noChangeClients, noChangeRooms, answerNickChooseAnother) - else - (modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick ++ (onLoginFinished client{nick = newNick} clients)) - where - haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients - -handleCmd_noInfo client clients _ ["PROTO", protoNum] = - if protocol client > 0 then - (noChangeClients, noChangeRooms, answerProtocolKnown) - else if parsedProto == 0 then - (noChangeClients, noChangeRooms, answerBadInput) - else - (modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto ++ (onLoginFinished client{protocol = parsedProto} clients)) - where - parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) - -handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) - - --- 'noRoom' clients state command handlers -handleCmd_noRoom :: CmdHandler -handleCmd_noRoom client clients rooms ["LIST"] = - (noChangeClients, noChangeRooms, (answerRoomsList $ concatMap roomInfo $ sameProtoRooms)) - where - roomInfo room = [ - name room, - (show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")", - show $ gameinprogress room - ] - sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms - -handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = - if haveSameRoom then - (noChangeClients, noChangeRooms, answerRoomExists) - else - (modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client) ++ (answerRoomAdded newRoom)) - where - haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms - -handleCmd_noRoom client clients rooms ["CREATE", newRoom] = - handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] - -handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] = - if noSuchRoom then - (noChangeClients, noChangeRooms, answerNoRoom) - else if roomPassword /= password clRoom then - (noChangeClients, noChangeRooms, answerWrongPassword) - else if isRestrictedJoins clRoom then - (noChangeClients, noChangeRooms, answerRestricted) - else - (modifyClient client{room = roomName}, modifyRoom clRoom{playersIn = 1 + playersIn clRoom}, (answerJoined $ nick client) ++ answerNicks ++ answerReady ++ (answerNotReady $ nick client) ++ answerFullConfig clRoom ++ answerTeams ++ watchRound) - where - noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms - answerNicks = if not $ null sameRoomClients then - answerClientOnly $ ["JOINED"] ++ (map nick $ sameRoomClients) - else - [] - answerReady = concatMap (\c -> answerClientOnly [if isReady c then "READY" else "NOT_READY", nick c]) sameRoomClients - sameRoomClients = filter (\ci -> room ci == roomName) clients - clRoom = roomByName roomName rooms - watchRound = if (roomProto clRoom < 20) || (not $ gameinprogress clRoom) then - [] - else - (answerClientOnly ["RUN_GAME"]) ++ - answerClientOnly ("GAMEMSG" : toEngineMsg "e$spectate 1" : (toList $ roundMsgs clRoom)) - answerTeams = if gameinprogress clRoom then - answerAllTeams (protocol client) (teamsAtStart clRoom) - else - answerAllTeams (protocol client) (teams clRoom) - -handleCmd_noRoom client clients rooms ["JOIN", roomName] = - handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] - -handleCmd_noRoom client _ _ ["CHAT_STRING", msg] = - (noChangeClients, noChangeRooms, answerChatString (nick client) msg) - -handleCmd_noRoom client _ _ ["GLOBALMSG", password, msg] = - (noChangeClients, noChangeRooms, [answer]) - where - answer = \serverInfo -> - if (not $ null password) && (adminPassword serverInfo == password) then - (allClients, ["CHAT_STRING", nick client, msg]) - else - (clientOnly, ["ERROR", "Wrong password"]) - -handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) - - --- 'inRoom' clients state command handlers -handleCmd_inRoom :: CmdHandler -handleCmd_inRoom client _ _ ["CHAT_STRING", msg] = - (noChangeClients, noChangeRooms, answerChatString (nick client) msg) - -handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) = - if isMaster client then - (noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs) - else - (noChangeClients, noChangeRooms, answerNotMaster) - where - clRoom = roomByName (room client) rooms - -handleCmd_inRoom client _ rooms ["PART"] = - if isMaster client then - (modifyRoomClients clRoom (\cl -> cl{isReady = False, isMaster = False, partRoom = True}), removeRoom (room client), (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client)) - else - if not $ gameinprogress clRoom then - (modifyClient client{ - isReady = False, - partRoom = True - }, - modifyRoom clRoom{ - teams = othersTeams, - playersIn = (playersIn clRoom) - 1, - readyPlayers = newReadyPlayers - }, - (answerPartInform (nick client)) ++ answerRemoveClientTeams) - else - (modifyClient client{ - isReady = False, - partRoom = True - }, - modifyRoom clRoom{ - teams = othersTeams, - leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom), - roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs), - playersIn = (playersIn clRoom) - 1, - readyPlayers = newReadyPlayers - }, - answerEngineTeamsRemoveMsg ++ - (answerPartInform (nick client)) ++ - answerRemoveClientTeams) - where - clRoom = roomByName (room client) rooms - answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams - (clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom - newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom - rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams - answerEngineTeamsRemoveMsg = - if not $ null rmTeamsMsgs then - answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs - else - [] - - -handleCmd_inRoom client _ rooms ["MAP", mapName] = - if isMaster client then - (noChangeClients, modifyRoom clRoom{gamemap = mapName}, answerMap mapName) - else - (noChangeClients, noChangeRooms, answerNotMaster) - where - clRoom = roomByName (room client) rooms - -handleCmd_inRoom client _ rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : difStr : hhsInfo) - | length hhsInfo == 16 = - if length (teams clRoom) == 6 then - (noChangeClients, noChangeRooms, answerCantAdd "too many teams") - else if canAddNumber <= 0 then - (noChangeClients, noChangeRooms, answerCantAdd "too many hedgehogs") - else if isJust findTeam then - (noChangeClients, noChangeRooms, answerCantAdd "already has a team with same name") - else if gameinprogress clRoom then - (noChangeClients, noChangeRooms, answerCantAdd "round in progress") - else if isRestrictedTeams clRoom then - (noChangeClients, noChangeRooms, answerCantAdd "restricted") - else - (noChangeClients, modifyRoom clRoom{teams = teams clRoom ++ [newTeam]}, answerTeamAccepted newTeam ++ answerAddTeam (protocol client) newTeam ++ answerTeamColor name color) - where - clRoom = roomByName (room client) rooms - newTeam = (TeamInfo (nick client) name color grave fort voicepack difficulty newTeamHHNum (hhsList hhsInfo)) - findTeam = find (\t -> name == teamname t) $ teams clRoom - difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) - hhsList [] = [] - hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs - canAddNumber = 48 - (sum . map hhnum $ teams clRoom) - newTeamHHNum = min 4 canAddNumber - -handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo) = - handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : "Default" : difStr : hhsInfo) - - -handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] = - if not $ isMaster client then - (noChangeClients, noChangeRooms, answerNotMaster) - else - if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then - (noChangeClients, noChangeRooms, []) - else - (noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber) - where - hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams clRoom - clRoom = roomByName (room client) rooms - canAddNumber = 48 - (sum . map hhnum $ teams clRoom) - -handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] = - if not $ isMaster client then - (noChangeClients, noChangeRooms, answerNotMaster) - else - if noSuchTeam then - (noChangeClients, noChangeRooms, []) - else - (noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor) - where - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams clRoom - clRoom = roomByName (room client) rooms - -handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] = - if noSuchTeam then - (noChangeClients, noChangeRooms, []) - else - if not $ nick client == teamowner team then - (noChangeClients, noChangeRooms, answerNotOwner) - else - if not $ gameinprogress clRoom then - (noChangeClients, modifyRoom clRoom{teams = filter (\t -> teamName /= teamname t) $ teams clRoom}, answerRemoveTeam teamName) - else - (noChangeClients, - modifyRoom clRoom{ - teams = filter (\t -> teamName /= teamname t) $ teams clRoom, - leftTeams = teamName : leftTeams clRoom, - roundMsgs = roundMsgs clRoom |> rmTeamMsg - }, - answerOthersRoom ["GAMEMSG", rmTeamMsg]) - where - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams clRoom - clRoom = roomByName (room client) rooms - rmTeamMsg = toEngineMsg $ 'F' : teamName - -handleCmd_inRoom client _ rooms ["TOGGLE_READY"] = - if isReady client then - (modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client) - else - (modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client) - where - clRoom = roomByName (room client) rooms - newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1 - -handleCmd_inRoom client _ rooms ["START_GAME"] = - if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then - if enoughClans then - (noChangeClients, modifyRoom clRoom{gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams clRoom}, answerRunGame) - else - (noChangeClients, noChangeRooms, answerTooFewClans) - else - (noChangeClients, noChangeRooms, []) - where - clRoom = roomByName (room client) rooms - enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom - -handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] = - if isMaster client then - (noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, []) - else - (noChangeClients, noChangeRooms, answerNotMaster) - where - clRoom = roomByName (room client) rooms - newStatus = not $ isRestrictedJoins clRoom - -handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] = - if isMaster client then - (noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, []) - else - (noChangeClients, noChangeRooms, answerNotMaster) - where - clRoom = roomByName (room client) rooms - newStatus = not $ isRestrictedTeams clRoom - -handleCmd_inRoom client clients rooms ["ROUNDFINISHED"] = - if isMaster client then - (modifyRoomClients clRoom (\cl -> cl{isReady = False}), modifyRoom clRoom{gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []}, answerAllNotReady ++ answerRemovedTeams) - else - (noChangeClients, noChangeRooms, []) - where - clRoom = roomByName (room client) rooms - sameRoomClients = filter (\ci -> room ci == name clRoom) clients - answerAllNotReady = concatMap (\cl -> answerSameRoom ["NOT_READY", nick cl]) sameRoomClients - answerRemovedTeams = concatMap (\t -> answerSameRoom ["REMOVE_TEAM", t]) $ leftTeams clRoom - -handleCmd_inRoom client _ rooms ["GAMEMSG", msg] = - (noChangeClients, addMsg, answerOthersRoom ["GAMEMSG", msg]) - where - addMsg = if roomProto clRoom < 20 then - noChangeRooms - else - modifyRoom clRoom{roundMsgs = roundMsgs clRoom |> msg} - clRoom = roomByName (room client) rooms - -handleCmd_inRoom client clients rooms ["KICK", kickNick] = - if isMaster client then - if noSuchClient || (kickClient == client) then - (noChangeClients, noChangeRooms, []) - else - (modifyClient kickClient{forceQuit = True}, noChangeRooms, []) - else - (noChangeClients, noChangeRooms, []) - where - clRoom = roomByName (room client) rooms - noSuchClient = isNothing findClient - kickClient = fromJust findClient - findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients - -handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)