{-
* Hedgewars, a free turn based strategy game
* Copyright (c) 2004-2015 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 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 Data.Word
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 as E
import System.Process
import Network.Socket
import System.Random
import qualified Data.Traversable as DT
import Text.Regex.TDFA
import qualified Text.Regex.TDFA as TDFA
import qualified Text.Regex.TDFA.ByteString as TDFAB
-----------------------------
#if defined(OFFICIAL_SERVER)
import OfficialServer.GameReplayStore
import qualified Data.Yaml as YAML
#endif
import CoreTypes
import Utils
import ClientIO
import ServerState
import Consts
import ConfigFile
import EngineInteraction
import FloodDetection
import HWProtoCore
import Votes
othersChans :: StateT ServerState IO [ClientChan]
othersChans = do
cl <- client's id
ri <- clientRoomA
liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
othersChansProto :: StateT ServerState IO [(ClientChan, Word16)]
othersChansProto = do
cl <- client's id
ri <- clientRoomA
map (\ci -> (sendChan ci, clientProto ci)) . filter (/= cl) <$> roomClientsS ri
processAction :: Action -> StateT ServerState IO ()
processAction (AnswerClients chans msg) =
io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
processAction (AnswerClientsByProto chansProto msgFunc) =
io $ mapM_ (\(chan, proto) -> writeChan chan (msgFunc proto)) chansProto
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 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 it 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
allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
mapM_ processAction [
AnswerClients chans ["JOINED", clNick]
, AnswerClients allClientsChans ["CLIENT_FLAGS", "+i", clNick]
, RegisterEvent RoomJoin
]
processAction (MoveToLobby msg) = do
(Just ci) <- gets clientIndex
ri <- clientRoomA
rnc <- gets roomsClients
playersNum <- io $ room'sM rnc playersIn ri
specialRoom <- io $ room'sM rnc isSpecial ri
master <- client's isMaster
-- client <- client's id
clNick <- client's nick
chans <- othersChans
if master then
if (playersNum > 1) || specialRoom 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]]
allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
processAction $ AnswerClients allClientsChans ["CLIENT_FLAGS", "-i", clNick]
-- when not removing room
ready <- client's isReady
when (not master || playersNum > 1 || specialRoom) . 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
specialRoom <- io $ room'sM rnc isSpecial ri
newMasterId <- if specialRoom then
return delegateId
else
liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc ri
newMaster <- io $ client'sM rnc id `DT.mapM` newMasterId
oldMasterId <- io $ room'sM rnc masterID ri
oldRoomName <- io $ room'sM rnc name ri
kicked <- client's isKickedFromServer
thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
let newRoomName = if ((proto < 42) || kicked) && (not specialRoom) then maybeNick newMaster else oldRoomName
when (isJust oldMasterId) $ do
oldMasterNick <- io $ client'sM rnc nick (fromJust oldMasterId)
mapM_ processAction [
ModifyClient2 (fromJust oldMasterId) (\c -> c{isMaster = False})
, AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMasterNick]
]
when (isJust newMasterId) $
mapM_ processAction [
ModifyClient2 (fromJust newMasterId) (\c -> c{isMaster = True})
, AnswerClients [sendChan $ fromJust newMaster] ["ROOM_CONTROL_ACCESS", "1"]
, AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick $ fromJust newMaster]
-- TODO: Send message to other clients, too (requires proper localization, however)
, AnswerClients [sendChan $ fromJust newMaster] ["CHAT", nickServer, loc "You're the new room master!"]
]
processAction $
ModifyRoom (\r -> r{masterID = newMasterId
, name = newRoomName
, isRestrictedJoins = False
, isRestrictedTeams = False
, isRegisteredOnly = isSpecial r}
)
newRoom' <- io $ room'sM rnc id ri
chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
let oldRoomNameByProto = roomNameByProto oldRoomName (roomProto newRoom')
processAction $ AnswerClientsByProto chansProto (\p -> "ROOM" : "UPD" : oldRoomNameByProto p : roomInfo p (maybeNick 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 = Just clId,
name = roomName,
password = roomPassword,
roomProto = proto
}
rId <- io $ addRoom rnc rm
processAction $ MoveToRoom rId
chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
mapM_ processAction [
AnswerClientsByProto chansProto (\p -> "ROOM" : "ADD" : roomInfo p 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
roomProto <- io $ room'sM rnc roomProto ri
others <- othersChansProto
chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
mapM_ processAction [
AnswerClientsByProto chansProto (\p -> ["ROOM", "DEL", roomNameByProto roomName roomProto p]),
AnswerClientsByProto others (\p -> ["ROOMABANDONED", roomNameByProto roomName roomProto p])
]
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
masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm)
chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS
let thisRoomNameByProto = roomNameByProto (name rm) (roomProto rm)
processAction $ AnswerClientsByProto chansProto (\p -> "ROOM" : "UPD" : thisRoomNameByProto p : roomInfo p (maybeNick masterCl) 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
rteams <- io $ room'sM rnc (L.nub . rejoinedTeams . fromJust . gameInfo) ri
mapM_ (processAction . RemoveTeam) rteams
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
, lastFilteredTimedMsg = Nothing
, roundMsgs = (if isJust $ lastFilteredTimedMsg g then ((:) rmTeamMsg . (:) (fromJust $ lastFilteredTimedMsg g)) else ((:) 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
n <- client's nick
removeTeamActions <- io $ do
rId <- clientRoomM rnc ci
roomTeams <- room'sM rnc teams rId
return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == n) $ roomTeams
mapM_ processAction removeTeamActions
processAction SetRandomSeed = do
ri <- clientRoomA
thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
seed <- liftM showB $ io $ (randomRIO (0, 10^9) :: IO Int)
mapM_ processAction [
ModifyRoom (\r -> r{mapParams = Map.insert "SEED" seed $ mapParams r})
, AnswerClients thisRoomChans ["CFG", "SEED", seed]
]
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
si <- gets serverInfo
case info of
HasAccount passwd isAdmin isContr -> do
b <- isBanned
c <- client's isChecker
when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin isContr
Guest | isRegisteredUsersOnly si -> do
processAction $ ByeClient $ loc "This server only allows registered users to join."
| otherwise -> do
b <- isBanned
c <- client's isChecker
when (not b) $
if c then
checkerLogin "" False False
else
processAction JoinLobby
Admin ->
mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
ReplayName fn -> processAction $ ShowReplay fn
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
chan <- client's sendChan
mapM_ processAction $
if wp == p then
[ModifyClient $ \c -> c{logonPassed = True}
, AnswerClients [chan] ["LOGONPASSED"]
]
else
[ByeClient $ loc "Authentication failed"]
playerLogin p a contr = do
cl <- client's id
mapM_ processAction [
AnswerClients [sendChan cl] $ ("ASKPASSWORD") : if clientProto cl < 48 then [] else [serverSalt cl]
, ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr})
]
processAction JoinLobby = do
chan <- client's sendChan
rnc <- gets roomsClients
clientNick <- client's nick
clProto <- client's clientProto
isAuthenticated <- client's isRegistered
isAdmin <- client's isAdministrator
isContr <- client's isContributor
loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS
let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
let authenticatedNicks = L.map nick . L.filter isRegistered $ loggedInClients
let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
let contrNicks = L.map nick . L.filter isContributor $ loggedInClients
inRoomNicks <- io $
allClientsM rnc
>>= filterM (liftM ((/=) lobbyId) . clientRoomM rnc)
>>= mapM (client'sM rnc nick)
let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin], ["c" | isContr]]
roomsInfoList <- io $ do
rooms <- roomsM rnc
mapM (\r -> (mapM (client'sM rnc id) $ masterID r)
>>= \cn -> return $ roomInfo clProto (maybeNick cn) r)
$ filter ((/=) 0 . roomProto) rooms
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] ("CLIENT_FLAGS" : "+c" : contrNicks) | not $ null contrNicks]
, [AnswerClients [chan] ("CLIENT_FLAGS" : "+i" : inRoomNicks) | not $ null inRoomNicks]
, [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS", B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]
, [ModifyClient (\cl -> cl{logonPassed = True, isVisible = True})]
, [SendServerMessage]
, [AnswerClients [chan] ("ROOMS" : concat roomsInfoList)]
]
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 $ loc "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 (\x -> forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci x)
infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
return ci
modify (\s -> s{clientIndex = Just newClId})
jm <- gets joinsMonitor
pass <- io $ joinsSentry jm (host cl) (connectTime cl)
if pass then
mapM_ processAction
[
CheckBanned True
, AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server https://www.hedgewars.org/", serverVersion]
]
else
processAction $ ByeClient $ loc "Reconnected too fast"
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, expiredBans) = L.partition (checkNotExpired clTime) $ bans si
let ban = L.find (checkBan byIP clHost clNick) $ validBans
mapM_ processAction $
[ModifyServerInfo (\s -> s{bans = validBans}) | not $ null expiredBans]
++ [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 _ _) = isMatch bip ip
checkBan False _ n (BanByNick bn _ _) = isMatch bn n
checkBan _ _ _ _ = False
isMatch :: B.ByteString -> B.ByteString -> Bool
isMatch rexp src = (==) (Just True) $ mrexp rexp >>= flip matchM src
mrexp :: B.ByteString -> Maybe TDFAB.Regex
mrexp = makeRegexOptsM TDFA.defaultCompOpt{TDFA.caseSensitive = False} TDFA.defaultExecOpt
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"
close 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 [loc "heads", loc "tails"] else items
n <- io $ randomRIO (0, length i - 1)
processAction $ AnswerClients chans ["CHAT", if null items then nickRandomCoin else nickRandomCustom, i !! n]
processAction (LoadGhost location) = do
ri <- clientRoomA
rnc <- gets roomsClients
thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
#if defined(OFFICIAL_SERVER)
rm <- io $ room'sM rnc id ri
points <- io $ loadFile (B.unpack $ "ghosts/" `B.append` sanitizeName location)
when (roomProto rm > 51) $ do
processAction $ ModifyRoom $ \r -> r{params = Map.insert "DRAWNMAP" [prependGhostPoints (toP points) $ head $ (params r) Map.! "DRAWNMAP"] (params r)}
#endif
cl <- client's id
rm <- io $ room'sM rnc id ri
mapM_ processAction $ map (replaceChans thisRoomChans) $ answerFullConfigParams cl (mapParams rm) (params rm)
where
loadFile :: String -> IO [Int]
loadFile fileName = E.handle (\(e :: SomeException) -> return []) $ do
points <- liftM read $ readFile fileName
return (points `deepseq` points)
replaceChans chans (AnswerClients _ msg) = AnswerClients chans msg
replaceChans _ a = a
toP [] = []
toP (p1:p2:ps) = (fromIntegral p1, fromIntegral p2) : toP ps
{-
let a = map (replaceChans chans) $ answerFullConfigParams cl mp p
-}
#if defined(OFFICIAL_SERVER)
processAction SaveReplay = do
ri <- clientRoomA
rnc <- gets roomsClients
readyCheckersIds <- io $ do
r <- room'sM rnc id ri
saveReplay r
allci <- allClientsM rnc
filterM (client'sM rnc isReadyChecker) allci
when (not $ null readyCheckersIds) $ do
oldci <- gets clientIndex
withStateT (\s -> s{clientIndex = Just $ head readyCheckersIds})
$ processAction CheckRecord
modify (\s -> s{clientIndex = oldci})
where
isReadyChecker cl = isChecker cl && isReady cl
processAction CheckRecord = do
p <- client's clientProto
c <- client's sendChan
ri <- clientRoomA
rnc <- gets roomsClients
blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS
(cinfo, l) <- io $ loadReplay (fromIntegral p) blackList
when (isJust cinfo) $
mapM_ processAction [
AnswerClients [c] ("REPLAY" : l)
, ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False}
]
processAction (CheckFailed msg) = do
Just (CheckInfo fileName _ _) <- client's checkInfo
io $ moveFailedRecord fileName
processAction (CheckSuccess info) = do
Just (CheckInfo fileName teams gameDetails) <- client's checkInfo
p <- client's clientProto
si <- gets serverInfo
when (isJust gameDetails)
$ io $ writeChan (dbQueries si) $ StoreAchievements p (B.pack fileName) (map toPair teams) (fromJust gameDetails) info
io $ moveCheckedRecord fileName
where
toPair t = (teamname t, teamowner t)
processAction (QueryReplay rname) = do
(Just ci) <- gets clientIndex
si <- gets serverInfo
uid <- client's clUID
io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) rname
processAction (ShowReplay rname) = do
c <- client's sendChan
cl <- client's id
let fileName = B.concat ["checked/", if B.isPrefixOf "replays/" rname then B.drop 8 rname else rname]
cInfo <- liftIO $ E.handle (\(e :: SomeException) ->
warningM "REPLAYS" (B.unpack $ B.concat ["Problems reading ", fileName, ": ", B.pack $ show e]) >> return Nothing) $ do
(t, p1, p2, msgs) <- liftM read $ readFile (B.unpack fileName)
return $ Just (t, Map.fromList p1, Map.fromList p2, reverse msgs)
let (teams', params1, params2, roundMsgs') = fromJust cInfo
when (isJust cInfo) $ do
mapM_ processAction $
if clientProto cl < 58 then
concat [
[AnswerClients [c] ["JOINED", nick cl]]
, answerFullConfigParams cl params1 params2
, answerAllTeams cl teams'
, [AnswerClients [c] ["RUN_GAME"]]
, [AnswerClients [c] $ "EM" : roundMsgs']
, [AnswerClients [c] ["KICKED"]]
]
else
concat [
[AnswerClients [c] ["REPLAY_START"]]
, answerFullConfigParams cl params1 params2
, answerAllTeams cl teams'
, [AnswerClients [c] ["RUN_GAME"]]
, [AnswerClients [c] $ "EM" : roundMsgs']
]
processAction (SaveRoom rname) = do
rnc <- gets roomsClients
ri <- clientRoomA
rm <- io $ room'sM rnc id ri
liftIO $ YAML.encodeFile (B.unpack rname) (greeting rm, roomSaves rm)
processAction (LoadRoom rname) = do
Right (g, rs) <- io $ YAML.decodeFileEither (B.unpack rname)
processAction $ ModifyRoom $ \r -> r{greeting = g, roomSaves = rs}
#else
processAction SaveReplay = return ()
processAction CheckRecord = return ()
processAction (CheckFailed _) = return ()
processAction (CheckSuccess _) = return ()
processAction (QueryReplay _) = processAction $ Warning $ loc "This server does not support replays!"
processAction (ShowReplay rname) = return ()
processAction (SaveRoom rname) = return () -- TODO: Send warning that this command is unsupported
processAction (LoadRoom rname) = return () -- TODO: Send warning that this command is unsupported
#endif
processAction Cleanup = do
jm <- gets joinsMonitor
io $ do
t <- getCurrentTime
cleanup jm t
processAction (RegisterEvent e) = do
actions <- registerEvent e
mapM_ processAction actions
processAction (ReactCmd cmd) = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
forM_ (actions `deepseq` actions) processAction
processAction CheckVotes =
checkVotes >>= mapM_ processAction
processAction (ShowRegisteredOnlyState chans) = do
si <- gets serverInfo
processAction $ AnswerClients chans
["CHAT", nickServer,
if isRegisteredUsersOnly si then
loc "This server no longer allows unregistered players to join."
else
loc "This server now allows unregistered players to join."
]