+
−{-# LANGUAGE OverloadedStrings #-}
+
−module Actions where
+
−
+
−import Control.Concurrent
+
−import qualified Data.Set as Set
+
−import qualified Data.Sequence as Seq
+
−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 OfficialServer.GameReplayStore
+
−import System.Process
+
−import Network.Socket
+
−-----------------------------
+
−import CoreTypes
+
−import Utils
+
−import ClientIO
+
−import ServerState
+
−import Consts
+
−import ConfigFile
+
−
+
−data Action =
+
−    AnswerClients ![ClientChan] ![B.ByteString]
+
−    | SendServerMessage
+
−    | SendServerVars
+
−    | MoveToRoom RoomIndex
+
−    | MoveToLobby B.ByteString
+
−    | RemoveTeam B.ByteString
+
−    | RemoveRoom
+
−    | UnreadyRoomClients
+
−    | JoinLobby
+
−    | ProtocolError B.ByteString
+
−    | Warning B.ByteString
+
−    | NoticeMessage Notice
+
−    | ByeClient B.ByteString
+
−    | KickClient ClientIndex
+
−    | KickRoomClient ClientIndex
+
−    | BanClient NominalDiffTime B.ByteString ClientIndex
+
−    | BanIP B.ByteString NominalDiffTime B.ByteString
+
−    | BanList
+
−    | ChangeMaster
+
−    | RemoveClientTeams ClientIndex
+
−    | ModifyClient (ClientInfo -> ClientInfo)
+
−    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
+
−    | ModifyRoom (RoomInfo -> RoomInfo)
+
−    | ModifyServerInfo (ServerInfo -> ServerInfo)
+
−    | AddRoom B.ByteString B.ByteString
+
−    | CheckRegistered
+
−    | ClearAccountsCache
+
−    | ProcessAccountInfo AccountInfo
+
−    | AddClient ClientInfo
+
−    | DeleteClient ClientIndex
+
−    | PingAll
+
−    | StatsAction
+
−    | RestartServer
+
−    | AddNick2Bans B.ByteString B.ByteString UTCTime
+
−    | AddIP2Bans B.ByteString B.ByteString UTCTime
+
−    | CheckBanned
+
−    | SaveReplay
+
−
+
−
+
−type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+
−
+
−instance NFData Action where
+
−    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
+
−    rnf a = a `seq` ()
+
−
+
−instance NFData B.ByteString
+
−instance NFData (Chan a)
+
−
+
−
+
−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 logonPassed
+
−
+
−    when (ri /= lobbyId) $ do
+
−        processAction $ MoveToLobby ("quit: " `B.append` msg)
+
−        return ()
+
−
+
−    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
+
−    io $
+
−        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
+
−
+
−    processAction $ AnswerClients [chan] ["BYE", msg]
+
−    when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
+
−
+
−    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 (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}) 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
+
−    (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri
+
−    ready <- client's isReady
+
−    master <- client's isMaster
+
−--    client <- client's id
+
−    clNick <- client's nick
+
−    chans <- othersChans
+
−
+
−    if master then
+
−        if gameProgress && playersNum > 1 then
+
−            mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]
+
−            else
+
−            processAction RemoveRoom
+
−        else
+
−        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
+
−
+
−    -- when not removing room
+
−    when (not master || (gameProgress && 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 = do
+
−    (Just ci) <- gets clientIndex
+
−    ri <- clientRoomA
+
−    rnc <- gets roomsClients
+
−    newMasterId <- liftM (head . filter (/= ci)) . io $ roomClientsIndicesM rnc ri
+
−    newMaster <- io $ client'sM rnc id newMasterId
+
−    let newRoomName = nick newMaster
+
−    mapM_ processAction [
+
−        ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),
+
−        ModifyClient2 newMasterId (\c -> c{isMaster = True}),
+
−        AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
+
−        ]
+
−
+
−processAction (AddRoom roomName roomPassword) = do
+
−    Just clId <- gets clientIndex
+
−    rnc <- gets roomsClients
+
−    proto <- io $ client'sM rnc clientProto clId
+
−
+
−    let rm = newRoom{
+
−            masterID = clId,
+
−            name = roomName,
+
−            password = roomPassword,
+
−            roomProto = proto
+
−            }
+
−
+
−    rId <- io $ addRoom rnc rm
+
−
+
−    processAction $ MoveToRoom rId
+
−
+
−    chans <- liftM (map sendChan) $! roomClientsS lobbyId
+
−
+
−    mapM_ processAction [
+
−        AnswerClients chans ["ROOM", "ADD", roomName]
+
−        , ModifyClient (\cl -> cl{isMaster = True})
+
−        ]
+
−
+
−
+
−processAction RemoveRoom = do
+
−    Just clId <- gets clientIndex
+
−    rnc <- gets roomsClients
+
−    ri <- io $ clientRoomM rnc clId
+
−    roomName <- io $ room'sM rnc name ri
+
−    others <- othersChans
+
−    lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
+
−
+
−    mapM_ processAction [
+
−            AnswerClients lobbyChans ["ROOM", "DEL", roomName],
+
−            AnswerClients others ["ROOMABANDONED", roomName]
+
−        ]
+
−
+
−    io $ removeRoom rnc ri
+
−
+
−
+
−processAction (UnreadyRoomClients) = do
+
−    rnc <- gets roomsClients
+
−    ri <- clientRoomA
+
−    roomPlayers <- roomClientsS ri
+
−    roomClIDs <- io $ roomClientsIndicesM rnc ri
+
−    pr <- client's clientProto
+
−    processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers)
+
−    io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
+
−    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
+
−    where
+
−        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
+
−
+
−
+
−processAction (RemoveTeam teamName) = do
+
−    rnc <- gets roomsClients
+
−    ri <- clientRoomA
+
−    inGame <- io $ room'sM rnc gameinprogress ri
+
−    chans <- othersChans
+
−    if not $ inGame then
+
−            mapM_ processAction [
+
−                AnswerClients chans ["REMOVE_TEAM", teamName],
+
−                ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
+
−                ]
+
−        else
+
−            mapM_ processAction [
+
−                AnswerClients chans ["EM", rmTeamMsg],
+
−                ModifyRoom (\r -> r{
+
−                    teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
+
−                    leftTeams = teamName : leftTeams r,
+
−                    roundMsgs = roundMsgs r Seq.|> rmTeamMsg
+
−                    })
+
−                ]
+
−    where
+
−        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
+
−
+
−
+
−processAction (RemoveClientTeams clId) = do
+
−    rnc <- gets roomsClients
+
−
+
−    removeTeamActions <- io $ do
+
−        clNick <- client'sM rnc nick clId
+
−        rId <- clientRoomM rnc clId
+
−        roomTeams <- room'sM rnc teams rId
+
−        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
+
−
+
−    mapM_ processAction removeTeamActions
+
−
+
−
+
−
+
−processAction CheckRegistered = do
+
−    (Just ci) <- gets clientIndex
+
−    n <- client's nick
+
−    h <- client's host
+
−    p <- client's clientProto
+
−    uid <- client's clUID
+
−    haveSameNick <- liftM (not . null . tail . filter (\c -> nick c == n)) allClientsS
+
−    if haveSameNick then
+
−        if p < 38 then
+
−            mapM_ processAction [ByeClient "Nickname is already in use", removeNick]
+
−            else
+
−            mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick]
+
−        else
+
−        do
+
−        db <- gets (dbQueries . serverInfo)
+
−        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
+
−        return ()
+
−   where
+
−       removeNick = ModifyClient (\c -> c{nick = ""})
+
−
+
−
+
−processAction ClearAccountsCache = do
+
−    dbq <- gets (dbQueries . serverInfo)
+
−    io $ writeChan dbq ClearCache
+
−    return ()
+
−
+
−
+
−processAction (ProcessAccountInfo info) =
+
−    case info of
+
−        HasAccount passwd isAdmin -> do
+
−            chan <- client's sendChan
+
−            mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
+
−        Guest ->
+
−            processAction JoinLobby
+
−        Admin -> do
+
−            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
+
−            chan <- client's sendChan
+
−            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
+
−
+
−
+
−processAction JoinLobby = do
+
−    chan <- client's sendChan
+
−    clientNick <- client's nick
+
−    (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS
+
−    mapM_ processAction $
+
−        AnswerClients clientsChans ["LOBBY:JOINED", clientNick]
+
−        : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)
+
−        : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
+
−
+
−
+
−processAction (KickClient kickId) = do
+
−    modify (\s -> s{clientIndex = Just kickId})
+
−    clHost <- client's host
+
−    currentTime <- io getCurrentTime
+
−    mapM_ processAction [
+
−        AddIP2Bans clHost "60 seconds cooldown after kick" (addUTCTime 60 currentTime),
+
−        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 BanList = do
+
−    ch <- client's sendChan
+
−    bans <- gets (bans . serverInfo)
+
−    processAction $
+
−        AnswerClients [ch] ["BANLIST", B.pack $ show bans]
+
−    
+
−
+
−
+
−processAction (KickRoomClient kickId) = do
+
−    modify (\s -> s{clientIndex = Just kickId})
+
−    ch <- client's sendChan
+
−    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "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
+
−            , 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 = 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 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 ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
+
−        checkBan _ n (BanByNick bn _ _) = bn == n
+
−        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) $
+
−                withStateT (\as -> as{clientIndex = Just ci}) $
+
−                    processAction (ByeClient "Ping timeout")
+
−
+
−
+
−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 SaveReplay = do
+
−    ri <- clientRoomA
+
−    rnc <- gets roomsClients
+
−    io $ do
+
−        r <- room'sM rnc id ri
+
−        saveReplay r