- Write server config into .ini file on change
- Import Data.TConfig into project, make it export Conf constructor, remove all workarounds for missing constructor in server.
{-# LANGUAGE OverloadedStrings #-}module Actions whereimport Control.Concurrentimport qualified Data.Set as Setimport qualified Data.Sequence as Seqimport System.Log.Loggerimport Control.Monadimport Data.Timeimport Data.Maybeimport Control.Monad.Readerimport Control.Monad.State.Strictimport qualified Data.ByteString.Char8 as Bimport Control.DeepSeqimport Data.Uniqueimport Control.Arrowimport Control.Exception-----------------------------import CoreTypesimport Utilsimport ClientIOimport ServerStateimport Constsimport ConfigFiledata 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 | 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 Booltype 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.ByteStringinstance NFData (Chan a)othersChans :: StateT ServerState IO [ClientChan]othersChans = do cl <- client's id ri <- clientRoomA liftM (map sendChan . filter (/= cl)) $ roomClientsS riprocessAction :: 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", B.pack . show $ 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", B.pack . show . fromEnum $ n]processAction (ByeClient msg) = do (Just ci) <- gets clientIndex ri <- clientRoomA chan <- client's sendChan clNick <- client's nick 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] processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] s <- get put $! s{removedClients = ci `Set.insert` removedClients s}processAction (DeleteClient ci) = do rnc <- gets roomsClients io $ removeClient rnc ci s <- get put $! s{removedClients = ci `Set.delete` removedClients s}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 siprocessAction (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] io $ do modifyRoom rnc (\r -> r{ playersIn = playersIn r - 1, readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r }) ri moveClientToLobby rnc ciprocessAction ChangeMaster = do ri <- clientRoomA rnc <- gets roomsClients newMasterId <- liftM head . 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 riprocessAction (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" : nicksprocessAction (RemoveTeam teamName) = do rnc <- gets roomsClients ri <- clientRoomA inGame <- io $ room'sM rnc gameinprogress ri chans <- othersChans if 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 $ B.singleton 'F' `B.append` teamNameprocessAction (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 removeTeamActionsprocessAction CheckRegistered = do (Just ci) <- gets clientIndex n <- client's nick h <- client's host uid <- client's clUID 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) = 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}) processAction $ ByeClient "Kicked"processAction (BanClient seconds reason banId) = do modify (\s -> s{clientIndex = Just banId}) clHost <- client's host currentTime <- io getCurrentTime let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")" mapM_ processAction [ ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds currentTime, msg)) : lastLogins s}) , KickClient banId ]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 t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci _ <- forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl)) return ci modify (\s -> s{clientIndex = Just newClId}) processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion] let newLogins = takeWhile (\(_ , (time, _)) -> connectTime cl `diffUTCTime` time <= 0) $ lastLogins si let info = host cl `Prelude.lookup` newLogins if isJust info then mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd . fromJust $ info)] else processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins})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 rnc <- gets roomsClients si <- gets serverInfo (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 force) = do if force then do throw RestartException else processAction $ ModifyServerInfo (\s -> s{restartPending=True})