{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Actions where
import Control.Concurrent
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.List as L
import qualified Control.Exception as Exception
import System.Log.Logger
import Control.Monad
import Data.Time
import Data.Maybe
import Control.Monad.Reader
import Control.Monad.State.Strict
import qualified Data.ByteString.Char8 as B
import Control.DeepSeq
import Data.Unique
import Control.Arrow
import Control.Exception
import System.Process
import Network.Socket
import System.Random
-----------------------------
#if defined(OFFICIAL_SERVER)
import OfficialServer.GameReplayStore
#endif
import CoreTypes
import Utils
import ClientIO
import ServerState
import Consts
import ConfigFile
import EngineInteraction
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
othersChans :: StateT ServerState IO [ClientChan]
othersChans = do
cl <- client's id
ri <- clientRoomA
liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
processAction :: Action -> StateT ServerState IO ()
processAction (AnswerClients chans msg) =
io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
processAction SendServerMessage = do
chan <- client's sendChan
protonum <- client's clientProto
si <- liftM serverInfo get
let message = if protonum < latestReleaseVersion si then
serverMessageForOldVersions si
else
serverMessage si
processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
processAction SendServerVars = do
chan <- client's sendChan
si <- gets serverInfo
io $ writeChan chan ("SERVER_VARS" : vars si)
where
vars si = [
"MOTD_NEW", serverMessage si,
"MOTD_OLD", serverMessageForOldVersions si,
"LATEST_PROTO", showB $ latestReleaseVersion si
]
processAction (ProtocolError msg) = do
chan <- client's sendChan
processAction $ AnswerClients [chan] ["ERROR", msg]
processAction (Warning msg) = do
chan <- client's sendChan
processAction $ AnswerClients [chan] ["WARNING", msg]
processAction (NoticeMessage n) = do
chan <- client's sendChan
processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
processAction (ByeClient msg) = do
(Just ci) <- gets clientIndex
ri <- clientRoomA
chan <- client's sendChan
clNick <- client's nick
loggedIn <- client's isVisible
when (ri /= lobbyId) $ do
processAction $ MoveToLobby ("quit: " `B.append` msg)
return ()
clientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
io $
infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
mapM_ processAction
[
AnswerClients [chan] ["BYE", msg]
, ModifyClient (\c -> c{nick = "", isVisible = False}) -- this will effectively hide client from others while he isn't deleted from list
]
s <- get
put $! s{removedClients = ci `Set.insert` removedClients s}
processAction (DeleteClient ci) = do
io $ debugM "Clients" $ "DeleteClient: " ++ show ci
rnc <- gets roomsClients
io $ removeClient rnc ci
s <- get
put $! s{removedClients = ci `Set.delete` removedClients s}
sp <- gets (shutdownPending . serverInfo)
cls <- allClientsS
io $ when (sp && null cls) $ throwIO ShutdownException
processAction (ModifyClient f) = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
io $ modifyClient rnc f ci
return ()
processAction (ModifyClient2 ci f) = do
rnc <- gets roomsClients
io $ modifyClient rnc f ci
return ()
processAction (ModifyRoomClients f) = do
rnc <- gets roomsClients
ri <- clientRoomA
roomClIDs <- io $ roomClientsIndicesM rnc ri
io $ mapM_ (modifyClient rnc f) roomClIDs
processAction (ModifyRoom f) = do
rnc <- gets roomsClients
ri <- clientRoomA
io $ modifyRoom rnc f ri
return ()
processAction (ModifyServerInfo f) = do
modify (\s -> s{serverInfo = f $ serverInfo s})
si <- gets serverInfo
io $ writeServerConfig si
processAction (MoveToRoom ri) = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
io $ do
modifyClient rnc (
\cl -> cl{teamsInGame = 0
, isReady = False
, isMaster = False
, isInGame = False
, isJoinedMidGame = False
, clientClan = Nothing}) ci
modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
moveClientToRoom rnc ri ci
chans <- liftM (map sendChan) $ roomClientsS ri
clNick <- client's nick
processAction $ AnswerClients chans ["JOINED", clNick]
processAction (MoveToLobby msg) = do
(Just ci) <- gets clientIndex
ri <- clientRoomA
rnc <- gets roomsClients
playersNum <- io $ room'sM rnc playersIn ri
master <- client's isMaster
-- client <- client's id
clNick <- client's nick
chans <- othersChans
if master then
if playersNum > 1 then
mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
else
processAction RemoveRoom
else
mapM_ processAction [RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
-- when not removing room
ready <- client's isReady
when (not master || playersNum > 1) . io $ do
modifyRoom rnc (\r -> r{
playersIn = playersIn r - 1,
readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
}) ri
moveClientToLobby rnc ci
processAction (ChangeMaster delegateId)= do
(Just ci) <- gets clientIndex
proto <- client's clientProto
ri <- clientRoomA
rnc <- gets roomsClients
newMasterId <- liftM (\ids -> fromMaybe (last . filter (/= ci) $ ids) delegateId) . io $ roomClientsIndicesM rnc ri
newMaster <- io $ client'sM rnc id newMasterId
oldMasterId <- io $ room'sM rnc masterID ri
oldMaster <- io $ client'sM rnc id oldMasterId
oldRoomName <- io $ room'sM rnc name ri
kicked <- client's isKickedFromServer
thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
let newRoomName = if (proto < 42) || kicked then nick newMaster else oldRoomName
mapM_ processAction [
ModifyRoom (\r -> r{masterID = newMasterId
, name = newRoomName
, isRestrictedJoins = False
, isRestrictedTeams = False
, isRegisteredOnly = False}
)
, ModifyClient2 newMasterId (\c -> c{isMaster = True})
, ModifyClient2 oldMasterId (\c -> c{isMaster = False})
, AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
, AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", nick oldMaster]
, AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick newMaster]
]
newRoom' <- io $ room'sM rnc id ri
chans <- liftM (map sendChan) $! sameProtoClientsS proto
processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo (nick newMaster) newRoom')
processAction (AddRoom roomName roomPassword) = do
Just clId <- gets clientIndex
rnc <- gets roomsClients
proto <- client's clientProto
n <- client's nick
let rm = newRoom{
masterID = clId,
name = roomName,
password = roomPassword,
roomProto = proto
}
rId <- io $ addRoom rnc rm
processAction $ MoveToRoom rId
chans <- liftM (map sendChan) $! sameProtoClientsS proto
mapM_ processAction [
AnswerClients chans ("ROOM" : "ADD" : roomInfo n rm{playersIn = 1})
]
processAction RemoveRoom = do
Just clId <- gets clientIndex
rnc <- gets roomsClients
ri <- io $ clientRoomM rnc clId
roomName <- io $ room'sM rnc name ri
others <- othersChans
proto <- client's clientProto
chans <- liftM (map sendChan) $! sameProtoClientsS proto
mapM_ processAction [
AnswerClients chans ["ROOM", "DEL", roomName],
AnswerClients others ["ROOMABANDONED", roomName]
]
io $ removeRoom rnc ri
processAction SendUpdateOnThisRoom = do
Just clId <- gets clientIndex
proto <- client's clientProto
rnc <- gets roomsClients
ri <- io $ clientRoomM rnc clId
rm <- io $ room'sM rnc id ri
n <- io $ client'sM rnc nick (masterID rm)
chans <- liftM (map sendChan) $! sameProtoClientsS proto
processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo n rm)
processAction UnreadyRoomClients = do
ri <- clientRoomA
roomPlayers <- roomClientsS ri
pr <- client's clientProto
mapM_ processAction [
AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr . map nick . filter (not . isMaster) $ roomPlayers
, ModifyRoomClients (\cl -> cl{isReady = isMaster cl, isJoinedMidGame = False})
, ModifyRoom (\r -> r{readyPlayers = 1})
]
where
notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
processAction FinishGame = do
rnc <- gets roomsClients
ri <- clientRoomA
thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
joinedMidGame <- liftM (filter isJoinedMidGame) $ roomClientsS ri
answerRemovedTeams <- io $
room'sM rnc (\r -> let gi = fromJust $ gameInfo r in
concatMap (\c ->
(answerFullConfigParams c (mapParams r) (params r))
++
(map (\t -> AnswerClients [sendChan c] ["REMOVE_TEAM", t]) $ leftTeams gi)
) joinedMidGame
) ri
mapM_ processAction $ (
SaveReplay
: ModifyRoom
(\r -> r{
gameInfo = Nothing,
readyPlayers = 0
}
)
: SendUpdateOnThisRoom
: AnswerClients thisRoomChans ["ROUND_FINISHED"]
: answerRemovedTeams
)
++ [UnreadyRoomClients]
processAction (SendTeamRemovalMessage teamName) = do
chans <- othersChans
mapM_ processAction [
AnswerClients chans ["EM", rmTeamMsg],
ModifyRoom (\r -> r{
gameInfo = liftM (\g -> g{
teamsInGameNumber = teamsInGameNumber g - 1
, roundMsgs = rmTeamMsg : roundMsgs g
}) $ gameInfo r
})
]
rnc <- gets roomsClients
ri <- clientRoomA
gi <- io $ room'sM rnc gameInfo ri
when (0 == teamsInGameNumber (fromJust gi)) $
processAction FinishGame
where
rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
processAction (RemoveTeam teamName) = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
ri <- clientRoomA
inGame <- io $ do
r <- room'sM rnc (isJust . gameInfo) ri
c <- client'sM rnc isInGame ci
return $ r && c
chans <- othersChans
mapM_ processAction $
ModifyRoom (\r -> r{
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r
, gameInfo = liftM (\g -> g{leftTeams = teamName : leftTeams g}) $ gameInfo r
})
: SendUpdateOnThisRoom
: AnswerClients chans ["REMOVE_TEAM", teamName]
: [SendTeamRemovalMessage teamName | inGame]
processAction RemoveClientTeams = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
removeTeamActions <- io $ do
rId <- clientRoomM rnc ci
roomTeams <- room'sM rnc teams rId
return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamownerId t == ci) $ roomTeams
mapM_ processAction removeTeamActions
processAction CheckRegistered = do
(Just ci) <- gets clientIndex
n <- client's nick
h <- client's host
p <- client's clientProto
checker <- client's isChecker
uid <- client's clUID
-- allow multiple checker logins
haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS
if (not checker) && haveSameNick then
if p < 38 then
processAction $ ByeClient $ loc "Nickname is already in use"
else
mapM_ processAction [NoticeMessage NickAlreadyInUse, ModifyClient $ \c -> c{nick = B.empty}]
else
do
db <- gets (dbQueries . serverInfo)
io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
return ()
processAction ClearAccountsCache = do
dbq <- gets (dbQueries . serverInfo)
io $ writeChan dbq ClearCache
return ()
processAction (ProcessAccountInfo info) = do
case info of
HasAccount passwd isAdmin -> do
b <- isBanned
c <- client's isChecker
when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin
Guest -> do
b <- isBanned
c <- client's isChecker
when (not b) $
if c then
checkerLogin "" False
else
processAction JoinLobby
Admin -> do
mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
chan <- client's sendChan
processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
where
isBanned = do
processAction $ CheckBanned False
liftM B.null $ client's nick
checkerLogin _ False = processAction $ ByeClient $ loc "No checker rights"
checkerLogin p True = do
wp <- client's webPassword
processAction $
if wp == p then ModifyClient $ \c -> c{logonPassed = True} else ByeClient $ loc "Authentication failed"
playerLogin p a = do
chan <- client's sendChan
mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = p, isAdministrator = a})]
processAction JoinLobby = do
chan <- client's sendChan
clientNick <- client's nick
isAuthenticated <- liftM (not . B.null) $ client's webPassword
isAdmin <- client's isAdministrator
loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS
let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
let authenticatedNicks = L.map nick . L.filter (not . B.null . webPassword) $ loggedInClients
let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin]]
mapM_ processAction . concat $ [
[AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]
, [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
, [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks]
, [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]
, [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS", B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]
, [ModifyClient (\cl -> cl{logonPassed = True, isVisible = True})]
, [SendServerMessage]
]
processAction (KickClient kickId) = do
modify (\s -> s{clientIndex = Just kickId})
clHost <- client's host
currentTime <- io getCurrentTime
mapM_ processAction [
AddIP2Bans clHost (loc "60 seconds cooldown after kick") (addUTCTime 60 currentTime)
, ModifyClient (\c -> c{isKickedFromServer = True})
, ByeClient "Kicked"
]
processAction (BanClient seconds reason banId) = do
modify (\s -> s{clientIndex = Just banId})
clHost <- client's host
currentTime <- io getCurrentTime
let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
mapM_ processAction [
AddIP2Bans clHost msg (addUTCTime seconds currentTime)
, KickClient banId
]
processAction (BanIP ip seconds reason) = do
currentTime <- io getCurrentTime
let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
processAction $
AddIP2Bans ip msg (addUTCTime seconds currentTime)
processAction (BanNick n seconds reason) = do
currentTime <- io getCurrentTime
let msg =
if seconds > 60 * 60 * 24 * 365 then
B.concat ["Permanent ban (", reason, ")"]
else
B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
processAction $
AddNick2Bans n msg (addUTCTime seconds currentTime)
processAction BanList = do
time <- io $ getCurrentTime
ch <- client's sendChan
b <- gets (B.intercalate "\n" . concatMap (ban2Str time) . bans . serverInfo)
processAction $
AnswerClients [ch] ["BANLIST", b]
where
ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time]
ban2Str time (BanByNick b r t) = ["N", b, r, B.pack . show $ t `diffUTCTime` time]
processAction (Unban entry) = do
processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s})
where
f (BanByIP bip _ _) = bip == entry
f (BanByNick bn _ _) = bn == entry
processAction (KickRoomClient kickId) = do
modify (\s -> s{clientIndex = Just kickId})
ch <- client's sendChan
mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]
processAction (AddClient cl) = do
rnc <- gets roomsClients
si <- gets serverInfo
newClId <- io $ do
ci <- addClient rnc cl
_ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci)
infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
return ci
modify (\s -> s{clientIndex = Just newClId})
mapM_ processAction
[
AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
, CheckBanned True
, AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl)
]
processAction (AddNick2Bans n reason expiring) = do
processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
processAction (AddIP2Bans ip reason expiring) = do
(Just ci) <- gets clientIndex
rc <- gets removedClients
when (not $ ci `Set.member` rc)
$ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
processAction (CheckBanned byIP) = do
clTime <- client's connectTime
clNick <- client's nick
clHost <- client's host
si <- gets serverInfo
let validBans = filter (checkNotExpired clTime) $ bans si
let ban = L.find (checkBan byIP clHost clNick) $ validBans
mapM_ processAction $
ModifyServerInfo (\s -> s{bans = validBans})
: [ByeClient (getBanReason $ fromJust ban) | isJust ban]
where
checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
checkBan True ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
checkBan False _ n (BanByNick bn _ _) = caseInsensitiveCompare bn n
checkBan _ _ _ _ = False
getBanReason (BanByIP _ msg _) = msg
getBanReason (BanByNick _ msg _) = msg
processAction PingAll = do
rnc <- gets roomsClients
io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
cis <- io $ allClientsM rnc
chans <- io $ mapM (client'sM rnc sendChan) cis
io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
processAction $ AnswerClients chans ["PING"]
where
kickTimeouted rnc ci = do
pq <- io $ client'sM rnc pingsQueue ci
when (pq > 0) $ do
withStateT (\as -> as{clientIndex = Just ci}) $
processAction (ByeClient $ loc "Ping timeout")
-- when (pq > 1) $
-- processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here
processAction StatsAction = do
si <- gets serverInfo
when (not $ shutdownPending si) $ do
rnc <- gets roomsClients
(roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
where
st irnc = (length $ allRooms irnc, length $ allClients irnc)
processAction RestartServer = do
sp <- gets (shutdownPending . serverInfo)
when (not sp) $ do
sock <- gets (fromJust . serverSocket . serverInfo)
args <- gets (runArgs . serverInfo)
io $ do
noticeM "Core" "Closing listening socket"
sClose sock
noticeM "Core" "Spawning new server"
_ <- createProcess (proc "./hedgewars-server" args)
return ()
processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
processAction Stats = do
cls <- allClientsS
rms <- allRoomsS
let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls
let roomsMap = Map.fromListWith (+) . map (\c -> (roomProto c, 1 :: Int)) . filter ((/=) 0 . roomProto) $ rms
let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap
let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"])
. concatMap (\p -> [
"<tr><td>", protoNumber2ver p
, "</td><td>", showB $ Map.findWithDefault 0 p clientsMap
, "</td><td>", showB $ Map.findWithDefault 0 p roomsMap
, "</td></tr>"])
. Set.toList $ keys
processAction $ Warning versionsStats
processAction (Random chans items) = do
let i = if null items then ["heads", "tails"] else items
n <- io $ randomRIO (0, length i - 1)
processAction $ AnswerClients chans ["CHAT", "[random]", i !! n]
#if defined(OFFICIAL_SERVER)
processAction SaveReplay = do
ri <- clientRoomA
rnc <- gets roomsClients
io $ do
r <- room'sM rnc id ri
saveReplay r
processAction CheckRecord = do
p <- client's clientProto
c <- client's sendChan
(cinfo, l) <- io $ loadReplay (fromIntegral p)
when (not . null $ l) $
mapM_ processAction [
AnswerClients [c] ("REPLAY" : l)
, ModifyClient $ \c -> c{checkInfo = cinfo}
]
processAction (CheckFailed msg) = do
Just (CheckInfo fileName _) <- client's checkInfo
io $ moveFailedRecord fileName
processAction (CheckSuccess info) = do
Just (CheckInfo fileName _) <- client's checkInfo
io $ moveCheckedRecord fileName
#else
processAction SaveReplay = return ()
processAction CheckRecord = return ()
processAction (CheckFailed _) = return ()
processAction (CheckSuccess _) = return ()
#endif