# HG changeset patch
# User unc0rr
# Date 1300037667 -10800
# Node ID af4e205e4b5a8d604a7b872f7cc036294f7e2db1
# Parent  12135f659bf1515d17259537bd2e1fc3f3363918# Parent  2efa6a414518da91186727451183f93faf365d38
merge

diff -r 2efa6a414518 -r af4e205e4b5a gameServer/Actions.hs
--- 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
diff -r 2efa6a414518 -r af4e205e4b5a gameServer/ConfigFile.hs
--- 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
diff -r 2efa6a414518 -r af4e205e4b5a gameServer/CoreTypes.hs
--- 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)
diff -r 2efa6a414518 -r af4e205e4b5a gameServer/Store.hs
--- 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
diff -r 2efa6a414518 -r af4e205e4b5a gameServer/stresstest.hs
--- 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