Use FreeAndNil across the board. Even if we are immediately assigning after, probably avoids accidental mistakes. Also free neglected owner tex on shutdown, and delete hog gears using the normal deletion procedure if for any reason they still exist (EndGame call?).
{-
* Hedgewars, a free turn based strategy game
* Copyright (c) 2004-2014 Andrey Korotaev <unC0Rr@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; version 2 of the License
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
\-}
{-# LANGUAGE OverloadedStrings #-}
module HWProtoInRoomState where
import qualified Data.Map as Map
import Data.List as L
import Data.Maybe
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Monad.Reader
--------------------------------------
import CoreTypes
import Utils
import HandlerUtils
import RoomsAndClients
import EngineInteraction
import Votes
startGame :: Reader (ClientIndex, IRnC) [Action]
startGame = do
(ci, rnc) <- ask
cl <- thisClient
rm <- thisRoom
chans <- roomClientsChans
let nicks = map (nick . client rnc) . roomClients rnc $ clientRoom rnc ci
let allPlayersRegistered = all ((<) 0 . B.length . webPassword . client rnc . teamownerId) $ teams rm
if (playersIn rm == readyPlayers rm || clientProto cl > 43) && not (isJust $ gameInfo rm) then
if enoughClans rm then
return [
ModifyRoom
(\r -> r{
gameInfo = Just $ newGameInfo (teams rm) (length $ teams rm) allPlayersRegistered (mapParams rm) (params rm) False
}
)
, AnswerClients chans ["RUN_GAME"]
, SendUpdateOnThisRoom
, AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks
, ModifyRoomClients (\c -> c{isInGame = True})
]
else
return [Warning $ loc "Less than two clans!"]
else
return []
where
enoughClans = not . null . drop 1 . group . map teamcolor . teams
handleCmd_inRoom :: CmdHandler
handleCmd_inRoom ["CHAT", msg] = do
n <- clientNick
s <- roomOthersChans
return [AnswerClients s ["CHAT", n, msg]]
handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
handleCmd_inRoom ("CFG" : paramName : paramStrs)
| null paramStrs = return [ProtocolError $ loc "Empty config entry"]
| otherwise = do
chans <- roomOthersChans
cl <- thisClient
rm <- thisRoom
if isSpecial rm then
return [Warning $ loc "Restricted"]
else if isMaster cl then
return [
ModifyRoom f,
AnswerClients chans ("CFG" : paramName : paramStrs)]
else
return [ProtocolError $ loc "Not room master"]
where
f r = if paramName `Map.member` (mapParams r) then
r{mapParams = Map.insert paramName (head paramStrs) (mapParams r)}
else
r{params = Map.insert paramName paramStrs (params r)}
handleCmd_inRoom ("ADD_TEAM" : tName : color : grave : fort : voicepack : flag : difStr : hhsInfo)
| length hhsInfo /= 16 = return [ProtocolError $ loc "Corrupted hedgehogs info"]
| otherwise = do
(ci, _) <- ask
rm <- thisRoom
clNick <- clientNick
clChan <- thisClientChans
othChans <- roomOthersChans
roomChans <- roomClientsChans
cl <- thisClient
teamColor <-
if clientProto cl < 42 then
return color
else
liftM (head . (L.\\) (map B.singleton ['0'..]) . map teamcolor . teams) thisRoom
let roomTeams = teams rm
let hhNum = let p = if not $ null roomTeams then minimum [hhnum $ head roomTeams, canAddNumber roomTeams] else 4 in newTeamHHNum roomTeams p
let newTeam = clNick `seq` TeamInfo ci clNick tName teamColor grave fort voicepack flag dif hhNum (hhsList hhsInfo)
return $
if not . null . drop (maxTeams rm - 1) $ roomTeams then
[Warning $ loc "too many teams"]
else if canAddNumber roomTeams <= 0 then
[Warning $ loc "too many hedgehogs"]
else if isJust $ findTeam rm then
[Warning $ loc "There's already a team with same name in the list"]
else if isJust $ gameInfo rm then
[Warning $ loc "round in progress"]
else if isRestrictedTeams rm then
[Warning $ loc "restricted"]
else
[ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
SendUpdateOnThisRoom,
ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = Just teamColor}),
AnswerClients clChan ["TEAM_ACCEPTED", tName],
AnswerClients othChans $ teamToNet $ newTeam,
AnswerClients roomChans ["TEAM_COLOR", tName, teamColor],
AnswerClients roomChans ["HH_NUM", tName, showB $ hhnum newTeam]
]
where
canAddNumber rt = (48::Int) - (sum $ map hhnum rt)
findTeam = find (\t -> tName == teamname t) . teams
dif = readInt_ difStr
hhsList [] = []
hhsList [_] = error "Hedgehogs list with odd elements number"
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
newTeamHHNum rt p = min p (canAddNumber rt)
maxTeams r
| roomProto r < 38 = 6
| otherwise = 8
handleCmd_inRoom ["REMOVE_TEAM", tName] = do
(ci, _) <- ask
r <- thisRoom
let maybeTeam = findTeam r
let team = fromJust maybeTeam
return $
if isNothing $ maybeTeam then
[Warning $ loc "REMOVE_TEAM: no such team"]
else if ci /= teamownerId team then
[ProtocolError $ loc "Not team owner!"]
else
[RemoveTeam tName,
ModifyClient
(\c -> c{
teamsInGame = teamsInGame c - 1,
clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci team r
})
]
where
anotherTeamClan ci team = teamcolor . fromMaybe (error "CHECKPOINT 011") . find (\t -> (teamownerId t == ci) && (t /= team)) . teams
findTeam = find (\t -> tName == teamname t) . teams
handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
cl <- thisClient
r <- thisRoom
clChan <- thisClientChans
others <- roomOthersChans
let maybeTeam = findTeam r
let team = fromJust maybeTeam
return $
if not $ isMaster cl then
[ProtocolError $ loc "Not room master"]
else if isNothing maybeTeam then
[]
else if hhNumber < 1 || hhNumber > 8 || hhNumber > canAddNumber r + hhnum team then
[AnswerClients clChan ["HH_NUM", teamName, showB $ hhnum team]]
else
[ModifyRoom $ modifyTeam team{hhnum = hhNumber},
AnswerClients others ["HH_NUM", teamName, showB hhNumber]]
where
hhNumber = readInt_ numberStr
findTeam = find (\t -> teamName == teamname t) . teams
canAddNumber = (-) 48 . sum . map hhnum . teams
handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do
cl <- thisClient
others <- roomOthersChans
r <- thisRoom
let maybeTeam = findTeam r
let team = fromJust maybeTeam
return $
if not $ isMaster cl then
[ProtocolError $ loc "Not room master"]
else if isNothing maybeTeam then
[]
else
[ModifyRoom $ modifyTeam team{teamcolor = newColor},
AnswerClients others ["TEAM_COLOR", teamName, newColor],
ModifyClient2 (teamownerId team) (\c -> c{clientClan = Just newColor})]
where
findTeam = find (\t -> teamName == teamname t) . teams
handleCmd_inRoom ["TOGGLE_READY"] = do
cl <- thisClient
rm <- thisRoom
chans <- roomClientsChans
(ci, rnc) <- ask
let ri = clientRoom rnc ci
let unreadyClients = filter (not . isReady) . map (client rnc) $ roomClients rnc ri
gs <- if (not $ isReady cl) && (isSpecial rm) && (unreadyClients == [cl]) then startGame else return []
return $
ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)})
: ModifyClient (\c -> c{isReady = not $ isReady cl})
: (AnswerClients chans $ if clientProto cl < 38 then
[if isReady cl then "NOT_READY" else "READY", nick cl]
else
["CLIENT_FLAGS", if isReady cl then "-r" else "+r", nick cl])
: gs
handleCmd_inRoom ["START_GAME"] = roomAdminOnly startGame
handleCmd_inRoom ["EM", msg] = do
cl <- thisClient
rm <- thisRoom
chans <- roomOthersChans
if teamsInGame cl > 0 && (isJust $ gameInfo rm) && (not $ B.null legalMsgs) then
return $ AnswerClients chans ["EM", legalMsgs]
: [ModifyRoom (\r -> r{gameInfo = liftM
(\g -> g{
roundMsgs = if B.null nonEmptyMsgs then roundMsgs g else nonEmptyMsgs : roundMsgs g
, lastFilteredTimedMsg = fromMaybe (lastFilteredTimedMsg g) lastFTMsg})
$ gameInfo r}), RegisterEvent EngineMessage]
else
return []
where
(legalMsgs, nonEmptyMsgs, lastFTMsg) = checkNetCmd msg
handleCmd_inRoom ["ROUNDFINISHED", _] = do
cl <- thisClient
rm <- thisRoom
chans <- roomClientsChans
let clTeams = map teamname . filter (\t -> teamowner t == nick cl) . teams $ rm
let unsetInGameState = [AnswerClients chans ["CLIENT_FLAGS", "-g", nick cl], ModifyClient (\c -> c{isInGame = False})]
if isInGame cl then
if isJust $ gameInfo rm then
return $ unsetInGameState ++ map SendTeamRemovalMessage clTeams
else
return unsetInGameState
else
return [] -- don't accept this message twice
where
-- isCorrect = correctly == "1"
-- compatibility with clients with protocol < 38
handleCmd_inRoom ["ROUNDFINISHED"] =
handleCmd_inRoom ["ROUNDFINISHED", "1"]
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = roomAdminOnly $
return [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r}), SendUpdateOnThisRoom]
handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = roomAdminOnly $
return [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
handleCmd_inRoom ["TOGGLE_REGISTERED_ONLY"] = roomAdminOnly $
return [ModifyRoom (\r -> r{isRegisteredOnly = not $ isRegisteredOnly r}), SendUpdateOnThisRoom]
handleCmd_inRoom ["ROOM_NAME", newName] = roomAdminOnly $ do
cl <- thisClient
rs <- allRoomInfos
rm <- thisRoom
chans <- sameProtoChans
return $
if illegalName newName then
[Warning $ loc "Illegal room name"]
else
if isSpecial rm then
[Warning $ loc "Restricted"]
else
if isJust $ find (\r -> newName == name r) rs then
[Warning $ loc "Room with such name already exists"]
else
[ModifyRoom roomUpdate,
AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo (clientProto cl) (nick cl) (roomUpdate rm))]
where
roomUpdate r = r{name = newName}
handleCmd_inRoom ["KICK", kickNick] = roomAdminOnly $ do
(thisClientId, rnc) <- ask
maybeClientId <- clientByNick kickNick
rm <- thisRoom
let kickId = fromJust maybeClientId
let kickCl = rnc `client` kickId
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
let notOnly2Players = (length . group . sort . map teamowner . teams $ rm) > 2
return
[KickRoomClient kickId |
isJust maybeClientId
&& (kickId /= thisClientId)
&& sameRoom
&& ((isNothing $ gameInfo rm) || notOnly2Players || teamsInGame kickCl == 0)
]
handleCmd_inRoom ["DELEGATE", newAdmin] = do
(thisClientId, rnc) <- ask
maybeClientId <- clientByNick newAdmin
master <- liftM isMaster thisClient
serverAdmin <- liftM isAdministrator thisClient
thisRoomMasterId <- liftM masterID thisRoom
let newAdminId = fromJust maybeClientId
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId
return
[ChangeMaster (Just newAdminId) |
(master || serverAdmin)
&& isJust maybeClientId
&& (Just newAdminId /= thisRoomMasterId)
&& sameRoom]
handleCmd_inRoom ["TEAMCHAT", msg] = do
cl <- thisClient
chans <- roomSameClanChans
return [AnswerClients chans ["EM", engineMsg cl]]
where
engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, " (team): ", msg, "\x20\x20"]
handleCmd_inRoom ["BAN", banNick] = do
(thisClientId, rnc) <- ask
maybeClientId <- clientByNick banNick
master <- liftM isMaster thisClient
let banId = fromJust maybeClientId
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId
if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then
return [
-- ModifyRoom (\r -> r{roomBansList = let h = host $ rnc `client` banId in h `deepseq` h : roomBansList r})
KickRoomClient banId
]
else
return []
handleCmd_inRoom ("RND":rs) = do
n <- clientNick
s <- roomClientsChans
return [AnswerClients s ["CHAT", n, B.unwords $ "/rnd" : rs], Random s rs]
handleCmd_inRoom ["FIX"] = serverAdminOnly $
return [ModifyRoom (\r -> r{isSpecial = True})]
handleCmd_inRoom ["UNFIX"] = serverAdminOnly $
return [ModifyRoom (\r -> r{isSpecial = False})]
handleCmd_inRoom ["GREETING", msg] = do
cl <- thisClient
rm <- thisRoom
return [ModifyRoom (\r -> r{greeting = msg}) | isAdministrator cl || (isMaster cl && (not $ isSpecial rm))]
handleCmd_inRoom ["CALLVOTE"] = do
cl <- thisClient
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "Available callvote commands: kick <nickname>, map <name>, pause"]]
handleCmd_inRoom ["CALLVOTE", "KICK"] = do
cl <- thisClient
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote kick: specify nickname"]]
handleCmd_inRoom ["CALLVOTE", "KICK", nickname] = do
(thisClientId, rnc) <- ask
cl <- thisClient
rm <- thisRoom
maybeClientId <- clientByNick nickname
let kickId = fromJust maybeClientId
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
if isJust $ masterID rm then
return []
else
if isJust maybeClientId && sameRoom then
startVote $ VoteKick nickname
else
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote kick: no such user"]]
handleCmd_inRoom ["CALLVOTE", "MAP"] = do
cl <- thisClient
s <- liftM (Map.keys . roomSaves) thisRoom
return [AnswerClients [sendChan cl] ["CHAT", "[server]", B.concat ["callvote map: ", B.intercalate ", " s]]]
handleCmd_inRoom ["CALLVOTE", "MAP", roomSave] = do
cl <- thisClient
rm <- thisRoom
if Map.member roomSave $ roomSaves rm then
startVote $ VoteMap roomSave
else
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote map: no such map"]]
handleCmd_inRoom ["CALLVOTE", "PAUSE"] = do
cl <- thisClient
rm <- thisRoom
if isJust $ gameInfo rm then
startVote VotePause
else
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote pause: no game in progress"]]
handleCmd_inRoom ["VOTE", m] = do
cl <- thisClient
let b = if m == "YES" then Just True else if m == "NO" then Just False else Nothing
if isJust b then
voted (fromJust b)
else
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "vote: 'yes' or 'no'"]]
handleCmd_inRoom ["SAVE", stateName] = serverAdminOnly $ do
return [ModifyRoom $ \r -> r{roomSaves = Map.insert stateName (mapParams r, params r) (roomSaves r)}]
handleCmd_inRoom ["DELETE", stateName] = serverAdminOnly $ do
return [ModifyRoom $ \r -> r{roomSaves = Map.delete stateName (roomSaves r)}]
handleCmd_inRoom ["SAVEROOM", fileName] = serverAdminOnly $ do
return [SaveRoom fileName]
handleCmd_inRoom ["LOADROOM", fileName] = serverAdminOnly $ do
return [LoadRoom fileName]
handleCmd_inRoom ["LIST"] = return [] -- for old clients (<= 0.9.17)
handleCmd_inRoom (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: in room)"]
handleCmd_inRoom [] = return [ProtocolError "Empty command (state: in room)"]