module Actions where
import Control.Concurrent
import Control.Concurrent.Chan
import qualified Data.IntSet as IntSet
import qualified Data.Sequence as Seq
import System.Log.Logger
import Monad
import Data.Time
import Maybe
import Control.Monad.Reader
-----------------------------
import CoreTypes
import Utils
import ClientIO
import RoomsAndClients
data Action =
AnswerClients [ClientChan] [String]
| SendServerMessage
| SendServerVars
| RoomAddThisClient Int -- roomID
| RoomRemoveThisClient String
| RemoveTeam String
| RemoveRoom
| UnreadyRoomClients
| MoveToLobby
| ProtocolError String
| Warning String
| ByeClient String
| KickClient Int -- clID
| KickRoomClient Int -- clID
| BanClient String -- nick
| RemoveClientTeams Int -- clID
| ModifyClient (ClientInfo -> ClientInfo)
| ModifyClient2 Int (ClientInfo -> ClientInfo)
| ModifyRoom (RoomInfo -> RoomInfo)
| ModifyServerInfo (ServerInfo -> ServerInfo)
| AddRoom String String
| CheckRegistered
| ClearAccountsCache
| ProcessAccountInfo AccountInfo
| Dump
| AddClient ClientInfo
| PingAll
| StatsAction
type CmdHandler = [String] -> Reader (ClientIndex, IRnC) [Action]
replaceID a (b, c, d, e) = (a, c, d, e)
processAction :: (ClientIndex, ServerInfo, MRnC) -> Action -> IO (ClientIndex, ServerInfo)
processAction (ci, serverInfo, rnc) (AnswerClients chans msg) = do
mapM_ (flip writeChan msg) chans
return (ci, serverInfo)
{-
processAction (clID, serverInfo, rnc) SendServerMessage = do
writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
return (clID, serverInfo, rnc)
where
client = clients ! clID
message si = if clientProto client < latestReleaseVersion si then
serverMessageForOldVersions si
else
serverMessage si
processAction (clID, serverInfo, rnc) SendServerVars = do
writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
return (clID, serverInfo, rnc)
where
client = clients ! clID
vars = [
"MOTD_NEW", serverMessage serverInfo,
"MOTD_OLD", serverMessageForOldVersions serverInfo,
"LATEST_PROTO", show $ latestReleaseVersion serverInfo
]
processAction (clID, serverInfo, rnc) (ProtocolError msg) = do
writeChan (sendChan $ clients ! clID) ["ERROR", msg]
return (clID, serverInfo, rnc)
processAction (clID, serverInfo, rnc) (Warning msg) = do
writeChan (sendChan $ clients ! clID) ["WARNING", msg]
return (clID, serverInfo, rnc)
-}
processAction (ci, serverInfo, rnc) (ByeClient msg) = do
infoM "Clients" (show ci ++ " quits: " ++ msg)
ri <- clientRoomM rnc ci
when (ri /= lobbyId)
processAction (ci, serverInfo, rnc) $ RoomRemoveThisClient ("quit: " ++ msg)
mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
writeChan (sendChan $ clients ! clID) ["BYE", msg]
return (
0,
serverInfo,
delete clID newClients,
adjust (\r -> r{
playersIDs = IntSet.delete clID (playersIDs r),
playersIn = (playersIn r) - 1,
readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
}) (roomID $ newClients ! clID) newRooms
)
where
client = clients ! clID
clientNick = nick client
answerInformRoom =
if roomID client /= 0 then
if not $ Prelude.null msg then
[AnswerThisRoom ["LEFT", clientNick, msg]]
else
[AnswerThisRoom ["LEFT", clientNick]]
else
[]
answerOthersQuit =
if logonPassed client then
if not $ Prelude.null msg then
[AnswerAll ["LOBBY:LEFT", clientNick, msg]]
else
[AnswerAll ["LOBBY:LEFT", clientNick]]
else
[]
{-
processAction (clID, serverInfo, rnc) (ModifyClient func) =
return (clID, serverInfo, adjust func clID rnc)
processAction (clID, serverInfo, rnc) (ModifyClient2 cl2ID func) =
return (clID, serverInfo, adjust func cl2ID rnc)
processAction (clID, serverInfo, rnc) (ModifyRoom func) =
return (clID, serverInfo, clients, adjust func rID rooms)
where
rID = roomID $ clients ! clID
processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
return (clID, func serverInfo, rnc)
processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
processAction (
clID,
serverInfo,
adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
) joinMsg
where
client = clients ! clID
joinMsg = if rID == 0 then
AnswerAllOthers ["LOBBY:JOINED", nick client]
else
AnswerThisRoom ["JOINED", nick client]
processAction (clID, serverInfo, rnc) (RoomRemoveThisClient msg) = do
(_, _, newClients, newRooms) <-
if roomID client /= 0 then
if isMaster client then
if (gameinprogress room) && (playersIn room > 1) then
(changeMaster >>= (\state -> foldM processAction state
[AnswerOthersInRoom ["LEFT", nick client, msg],
AnswerOthersInRoom ["WARNING", "Admin left the room"],
RemoveClientTeams clID]))
else -- not in game
processAction (clID, serverInfo, rnc) RemoveRoom
else -- not master
foldM
processAction
(clID, serverInfo, rnc)
[AnswerOthersInRoom ["LEFT", nick client, msg],
RemoveClientTeams clID]
else -- in lobby
return (clID, serverInfo, rnc)
return (
clID,
serverInfo,
adjust resetClientFlags clID newClients,
adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
)
where
rID = roomID client
client = clients ! clID
room = rooms ! rID
resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
removeClientFromRoom r = r{
playersIDs = otherPlayersSet,
playersIn = (playersIn r) - 1,
readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
}
insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
changeMaster = do
processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
return (
clID,
serverInfo,
adjust (\cl -> cl{isMaster = True}) newMasterId clients,
adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
)
newRoomName = nick newMasterClient
otherPlayersSet = IntSet.delete clID (playersIDs room)
newMasterId = IntSet.findMin otherPlayersSet
newMasterClient = clients ! newMasterId
processAction (clID, serverInfo, rnc) (AddRoom roomName roomPassword) = do
let newServerInfo = serverInfo {nextRoomID = newID}
let room = newRoom{
roomUID = newID,
masterID = clID,
name = roomName,
password = roomPassword,
roomProto = (clientProto client)
}
processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "ADD", roomName]
processAction (
clID,
newServerInfo,
adjust (\cl -> cl{isMaster = True}) clID clients,
insert newID room rooms
) $ RoomAddThisClient newID
where
newID = (nextRoomID serverInfo) - 1
client = clients ! clID
processAction (clID, serverInfo, rnc) (RemoveRoom) = do
processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room]
processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
return (clID,
serverInfo,
Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
)
where
room = rooms ! rID
rID = roomID client
client = clients ! clID
processAction (clID, serverInfo, rnc) (UnreadyRoomClients) = do
processAction (clID, serverInfo, rnc) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
return (clID,
serverInfo,
Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
adjust (\r -> r{readyPlayers = 0}) rID rooms)
where
room = rooms ! rID
rID = roomID client
client = clients ! clID
roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
roomPlayersIDs = IntSet.elems $ playersIDs room
processAction (clID, serverInfo, rnc) (RemoveTeam teamName) = do
newRooms <- if not $ gameinprogress room then
do
processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
return $
adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
else
do
processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["EM", rmTeamMsg]
return $
adjust (\r -> r{
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
leftTeams = teamName : leftTeams r,
roundMsgs = roundMsgs r Seq.|> rmTeamMsg
}) rID rooms
return (clID, serverInfo, clients, newRooms)
where
room = rooms ! rID
rID = roomID client
client = clients ! clID
rmTeamMsg = toEngineMsg $ 'F' : teamName
processAction (clID, serverInfo, rnc) (CheckRegistered) = do
writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
return (clID, serverInfo, rnc)
where
client = clients ! clID
processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do
writeChan (dbQueries serverInfo) ClearCache
return (clID, serverInfo, rnc)
where
client = clients ! clID
processAction (clID, serverInfo, rnc) (Dump) = do
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
return (clID, serverInfo, rnc)
processAction (clID, serverInfo, rnc) (ProcessAccountInfo info) =
case info of
HasAccount passwd isAdmin -> do
infoM "Clients" $ show clID ++ " has account"
writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID rnc)
Guest -> do
infoM "Clients" $ show clID ++ " is guest"
processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID rnc) MoveToLobby
Admin -> do
infoM "Clients" $ show clID ++ " is admin"
foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID rnc) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
processAction (clID, serverInfo, rnc) (MoveToLobby) =
foldM processAction (clID, serverInfo, rnc) $
(RoomAddThisClient 0)
: answerLobbyNicks
++ [SendServerMessage]
-- ++ (answerServerMessage client clients)
where
lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
processAction (clID, serverInfo, rnc) (KickClient kickID) =
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
processAction (clID, serverInfo, rnc) (BanClient banNick) =
return (clID, serverInfo, rnc)
processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do
writeChan (sendChan $ clients ! kickID) ["KICKED"]
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) =
liftM2 replaceID (return clID) $
foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions
where
client = clients ! teamsClID
room = rooms ! (roomID client)
teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
-}
processAction (_, serverInfo, rnc) (AddClient client) = do
ci <- addClient rnc client
forkIO $ clientRecvLoop (clientHandle client) (coreChan serverInfo) ci
forkIO $ clientSendLoop (clientHandle client) (coreChan serverInfo) (sendChan client) ci
infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
if False && (isJust $ host client `Prelude.lookup` newLogins) then
processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
else
return (ci, serverInfo)
{-
processAction (clID, serverInfo, rnc) PingAll = do
(_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, rnc) $ elems clients
processAction (clID,
serverInfo,
Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
newRooms) $ AnswerAll ["PING"]
where
kickTimeouted (clID, serverInfo, rnc) client =
if pingsQueue client > 0 then
processAction (clientUID client, serverInfo, rnc) $ ByeClient "Ping timeout"
else
return (clID, serverInfo, rnc)
processAction (clID, serverInfo, rnc) (StatsAction) = do
writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
return (clID, serverInfo, rnc)
-}