hedgewars: comparison gameServer/Actions.hs

equal deleted inserted replaced

-:46a9fde631f4
+:75db7bb8dce8
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Actions where
 import Control.Concurrent
 import qualified Data.Set as Set
-import qualified Data.Sequence as Seq
+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
 | BanIP B.ByteString NominalDiffTime B.ByteString
 | BanNick B.ByteString NominalDiffTime B.ByteString
 | BanList
 | Unban B.ByteString
 | ChangeMaster (Maybe ClientIndex)
-| RemoveClientTeams ClientIndex
+| RemoveClientTeams
 | ModifyClient (ClientInfo -> ClientInfo)
 | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
 | ModifyRoomClients (ClientInfo -> ClientInfo)
 | ModifyRoom (RoomInfo -> RoomInfo)
 | ModifyServerInfo (ServerInfo -> ServerInfo)
 | RestartServer
 | AddNick2Bans B.ByteString B.ByteString UTCTime
 | AddIP2Bans B.ByteString B.ByteString UTCTime
 | CheckBanned Bool
 | SaveReplay
+| Stats
 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 B.ByteString
 instance NFData (Chan a)
 othersChans :: StateT ServerState IO [ClientChan]
 othersChans = do
 (Just ci) <- gets clientIndex
 ri <- clientRoomA
 chan <- client's sendChan
 clNick <- client's nick
-loggedIn <- client's logonPassed
+loggedIn <- client's isVisible
 when (ri /= lobbyId) $ do
 processAction $ MoveToLobby ("quit: " `B.append` msg)
 return ()
-clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
+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 = "", logonPassed = False}) -- this will effectively hide client from others while he isn't deleted from list
+, 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}
 clNick <- client's nick
 chans <- othersChans
 if master then
 if playersNum > 1 then
-mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
+mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
 else
 processAction RemoveRoom
 else
-mapM_ processAction [RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
+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{
 mapM_ processAction [
 AnswerClients chans ["EM", rmTeamMsg],
 ModifyRoom (\r -> r{
 gameInfo = liftM (\g -> g{
 teamsInGameNumber = teamsInGameNumber g - 1
-, roundMsgs = roundMsgs g Seq.|> rmTeamMsg
+, roundMsgs = rmTeamMsg : roundMsgs g
 }) $ gameInfo r
 })
 ]
 rnc <- gets roomsClients
 ri <- clientRoomA
 gi <- io $ room'sM rnc gameInfo ri
-when (isJust gi && 0 == teamsInGameNumber (fromJust gi)) $
+when (0 == teamsInGameNumber (fromJust gi)) $
 processAction FinishGame
 where
 rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
 processAction (RemoveTeam teamName) = do
-rnc <- gets roomsClients
+(Just ci) <- gets clientIndex
-ri <- clientRoomA
+rnc <- gets roomsClients
-inGame <- io $ room'sM rnc (isJust . gameInfo) ri
+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 clId) = do
+processAction RemoveClientTeams = do
+(Just ci) <- gets clientIndex
 rnc <- gets roomsClients
 removeTeamActions <- io $ do
-clNick <- client'sM rnc nick clId
+rId <- clientRoomM rnc ci
-rId <- clientRoomM rnc clId
 roomTeams <- room'sM rnc teams rId
-return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
+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
-haveSameNick <- liftM (not . null . tail . filter (\c -> caseInsensitiveCompare (nick c) n)) allClientsS
+-- allow multiple checker logins
-if haveSameNick then
+haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS
+if haveSameNick && (not checker) then
 if p < 38 then
-processAction $ ByeClient "Nickname is already in use"
+processAction $ ByeClient $ loc "Nickname is already in use"
 else
 processAction $ NoticeMessage NickAlreadyInUse
 else
 do
 db <- gets (dbQueries . serverInfo)
 processAction (ProcessAccountInfo info) = do
 case info of
 HasAccount passwd isAdmin -> do
 b <- isBanned
-when (not b) $ do
+c <- client's isChecker
-chan <- client's sendChan
+when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin
-mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
 Guest -> do
 b <- isBanned
 when (not b) $
 processAction JoinLobby
 Admin -> do
 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 logonPassed) $! allClientsS
+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})]
+, [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 "60 seconds cooldown after kick" (addUTCTime 60 currentTime)
+AddIP2Bans clHost (loc "60 seconds cooldown after kick") (addUTCTime 60 currentTime)
 , ModifyClient (\c -> c{isKickedFromServer = True})
 , ByeClient "Kicked"
 ]
 processAction (KickRoomClient kickId) = do
 modify (\s -> s{clientIndex = Just kickId})
 ch <- client's sendChan
-mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
+mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]
 processAction (AddClient cl) = do
 rnc <- gets roomsClients
 si <- gets serverInfo
 where
 kickTimeouted rnc ci = do
 pq <- io $ client'sM rnc pingsQueue ci
 when (pq > 0) $ do
 withStateT (\as -> as{clientIndex = Just ci}) $
-processAction (ByeClient "Ping timeout")
+processAction (ByeClient $ loc "Ping timeout")
 --                when (pq > 1) $
 --                    processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here
 processAction StatsAction = do
 noticeM "Core" "Spawning new server"
 _ <- createProcess (proc "./hedgewars-server" args)
 return ()
 processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
+processAction Stats = do
+cls <- allClientsS
+let stats = versions cls
+processAction $ Warning stats
+where
+versions = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"])
+. concatMap (\(p, n :: Int) -> ["<tr><td>", protoNumber2ver p, "</td><td>", showB n, "</td></tr>"])
+. Map.toList . Map.fromListWith (+) . map (\c -> (clientProto c, 1))
 #if defined(OFFICIAL_SERVER)
 processAction SaveReplay = do
 ri <- clientRoomA
 rnc <- gets roomsClients
 io $ do
 r <- room'sM rnc id ri
 saveReplay r
 #else
 processAction SaveReplay = return ()

branch	webgl
changeset 8444	75db7bb8dce8
parent 8330	aaefa587e277
parent 8439	3850c4bfe6b5
child 8833	c13ebed437cb