--- a/gameServer/Actions.hs Sun Mar 13 18:23:51 2011 +0100
+++ b/gameServer/Actions.hs Sun Mar 13 20:34:27 2011 +0300
@@ -4,6 +4,7 @@
import Control.Concurrent
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
+import qualified Data.List as L
import System.Log.Logger
import Control.Monad
import Data.Time
@@ -55,6 +56,9 @@
| PingAll
| StatsAction
| RestartServer Bool
+ | AddNick2Bans B.ByteString B.ByteString UTCTime
+ | AddIP2Bans B.ByteString B.ByteString UTCTime
+ | CheckBanned
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
@@ -374,7 +378,7 @@
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})
+ AddIP2Bans clHost msg (addUTCTime seconds currentTime)
, KickClient banId
]
@@ -398,15 +402,42 @@
return ci
modify (\s -> s{clientIndex = Just newClId})
- processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
+ 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})
- 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 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
+ when (isJust ban) $
+ mapM_ processAction [
+ ModifyServerInfo (\s -> s{bans = validBans})
+ , ByeClient (getBanReason $ fromJust ban)
+ ]
+ where
+ checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
+ checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
+ checkBan ip _ (BanByIP bip _ _) = bip == ip
+ checkBan _ n (BanByNick bn _ _) = bn == n
+ getBanReason (BanByIP _ msg _) = msg
+ getBanReason (BanByNick _ msg _) = msg
processAction PingAll = do
rnc <- gets roomsClients
--- a/gameServer/ConfigFile.hs Sun Mar 13 18:23:51 2011 +0100
+++ b/gameServer/ConfigFile.hs Sun Mar 13 20:34:27 2011 +0300
@@ -21,6 +21,7 @@
, dbPassword = value "dbPassword" cfg
, serverMessage = value "sv_message" cfg
, serverMessageForOldVersions = value "sv_messageOld" cfg
+ , bans = read . fromJust2 "bans" $ getValue "bans" cfg
, latestReleaseVersion = read . fromJust $ getValue "sv_latestProto" cfg
, serverConfig = Just cfg
}
@@ -40,13 +41,16 @@
dbPassword = dp,
serverMessage = sm,
serverMessageForOldVersions = smo,
+ bans = b,
latestReleaseVersion = ver,
serverConfig = Just cfg}
- = do
- let newCfg = foldl (\c (n, v) -> repConfig n (B.unpack v) c) cfg entries
- writeConfig cfgFileName (repConfig "sv_latestProto" (show ver) newCfg)
+ =
+ writeConfig cfgFileName $ foldl1 (.) entries cfg
where
- entries = [
+ entries =
+ repConfig "sv_latestProto" (show ver)
+ : repConfig "bans" (show b)
+ : map (\(n, v) -> repConfig n (B.unpack v)) [
("dbHost", dh)
, ("dbName", dn)
, ("dbLogin", dl)
@@ -54,3 +58,4 @@
, ("sv_message", sm)
, ("sv_messageOld", smo)
]
+
\ No newline at end of file
--- a/gameServer/CoreTypes.hs Sun Mar 13 18:23:51 2011 +0100
+++ b/gameServer/CoreTypes.hs Sun Mar 13 20:34:27 2011 +0300
@@ -39,9 +39,6 @@
teamsInGame :: Word
}
-instance Show ClientInfo where
- show ci = " nick: " ++ unpack (nick ci) ++ " host: " ++ unpack (host ci)
-
instance Eq ClientInfo where
(==) = (==) `on` clientSocket
@@ -64,11 +61,6 @@
hedgehogs :: [HedgehogInfo]
}
-instance Show TeamInfo where
- show ti = "owner: " ++ unpack (teamowner ti)
- ++ "name: " ++ unpack (teamname ti)
- ++ "color: " ++ unpack (teamcolor ti)
-
data RoomInfo =
RoomInfo
{
@@ -89,11 +81,6 @@
params :: Map.Map B.ByteString [B.ByteString]
}
-instance Show RoomInfo where
- show ri = ", players: " ++ show (playersIn ri)
- ++ ", ready: " ++ show (readyPlayers ri)
- ++ ", teams: " ++ show (teams ri)
-
newRoom :: RoomInfo
newRoom =
RoomInfo
@@ -138,15 +125,13 @@
dbName :: B.ByteString,
dbLogin :: B.ByteString,
dbPassword :: B.ByteString,
- lastLogins :: [(B.ByteString, (UTCTime, B.ByteString))],
+ bans :: [BanInfo],
restartPending :: Bool,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery,
serverConfig :: Maybe Conf
}
-instance Show ServerInfo where
- show _ = "Server Info"
newServerInfo :: Chan CoreMessage -> Chan DBQuery -> Maybe Conf -> ServerInfo
newServerInfo =
@@ -184,13 +169,6 @@
| TimerAction Int
| Remove ClientIndex
-instance Show CoreMessage where
- show (Accept _) = "Accept"
- show (ClientMessage _) = "ClientMessage"
- show (ClientAccountInfo {}) = "ClientAccountInfo"
- show (TimerAction _) = "TimerAction"
- show (Remove _) = "Remove"
-
type MRnC = MRoomsAndClients RoomInfo ClientInfo
type IRnC = IRoomsAndClients RoomInfo ClientInfo
@@ -212,3 +190,8 @@
instance Show ShutdownThreadException where
show (ShutdownThreadException s) = s
instance Exception ShutdownThreadException
+
+data BanInfo =
+ BanByIP B.ByteString B.ByteString UTCTime
+ | BanByNick B.ByteString B.ByteString UTCTime
+ deriving (Show, Read)
--- a/gameServer/Store.hs Sun Mar 13 18:23:51 2011 +0100
+++ b/gameServer/Store.hs Sun Mar 13 20:34:27 2011 +0300
@@ -35,12 +35,16 @@
-- MStore code
initialSize :: Int
-initialSize = 10
+initialSize = 16
growFunc :: Int -> Int
growFunc a = a * 3 `div` 2
+truncFunc :: Int -> Int
+truncFunc a | a > growFunc initialSize = (a `div` 2)
+ | otherwise = a
+
newStore :: IO (MStore e)
newStore = do
@@ -65,6 +69,25 @@
when (IntSet.null freeElems) $ growStore m
+truncateStore :: MStore e -> IO ()
+truncateStore (MStore ref) = do
+ (busyElems, freeElems, arr) <- readIORef ref
+ (_, m') <- IOA.getBounds arr
+ let newM' = truncFunc (m' + 1) - 1
+ newArr <- IOA.newArray_ (0, newM')
+ sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- IntSet.toList busyElems]
+ writeIORef ref (busyElems, freeElems `IntSet.difference` IntSet.fromAscList [newM'..m'+1], newArr)
+
+
+truncateIfNeeded :: MStore e -> IO ()
+truncateIfNeeded m@(MStore ref) = do
+ (busyElems, _, arr) <- readIORef ref
+ (_, m') <- IOA.getBounds arr
+ let newM' = truncFunc (m' + 1) - 1
+ let allLessM = all (< newM') $ IntSet.elems busyElems
+ when (newM' < m' && allLessM) $ truncateStore m
+
+
addElem :: MStore e -> e -> IO ElemIndex
addElem m@(MStore ref) element = do
growIfNeeded m
@@ -76,10 +99,11 @@
removeElem :: MStore e -> ElemIndex -> IO ()
-removeElem (MStore ref) (ElemIndex n) = do
+removeElem m@(MStore ref) (ElemIndex n) = do
(busyElems, freeElems, arr) <- readIORef ref
IOA.writeArray arr n (error $ "Store: no element " ++ show n)
writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
+ truncateIfNeeded m
readElem :: MStore e -> ElemIndex -> IO e
--- a/gameServer/stresstest.hs Sun Mar 13 18:23:51 2011 +0100
+++ b/gameServer/stresstest.hs Sun Mar 13 20:34:27 2011 +0300
@@ -19,7 +19,7 @@
session3 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROON", room, "", "CHAT", "room 2", "", "QUIT", "quit", ""]
emulateSession sock s = do
- mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (30000::Int, 59000) >>= threadDelay) s
+ mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (3000000::Int, 5900000) >>= threadDelay) s
hFlush sock
threadDelay 225000