gameServer/FloodDetection.hs
author Wuzzy <almikes@aol.com>
Sat, 15 Apr 2017 04:28:00 +0200
changeset 12253 8e9603088f99
parent 11466 4b5c7a5c49fd
child 14862 111c4d750c6d
permissions -rw-r--r--
Make all hogs say Yessir taunt on their turn start (replaces revenge taunts) Rationale: The taunts Illgetyou, JustYouWait were fairly odd and almost always inapproriate to the situation as most voicepacks clearly assume these to be used for revenge only (e.g. “You'll gonna pay for that.” was played at turn start because of this.).
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10464
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     1
{-
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10464
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10464
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     4
 *
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     8
 *
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    12
 * GNU General Public License for more details.
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    13
 *
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    14
 * You should have received a copy of the GNU General Public License
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    15
 * along with this program; if not, write to the Free Software
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    17
 \-}
d08611b52000 Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10095
diff changeset
    18
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    19
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
    20
module FloodDetection where
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
    21
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    22
import Control.Monad.State.Strict
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    23
import Data.Time
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    24
import Control.Arrow
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    25
----------------
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    26
import ServerState
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
    27
import CoreTypes
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    28
import Utils
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
    29
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    30
registerEvent :: Event -> StateT ServerState IO [Action]
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    31
registerEvent e = do
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    32
    eventInfo <- client's $ einfo e
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    33
    if (null eventInfo) || 0 == (fst $ head eventInfo) then doCheck eventInfo else updateInfo
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    34
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    35
    where
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    36
    einfo LobbyChatMessage = eiLobbyChat
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    37
    einfo EngineMessage = eiEM
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    38
    einfo RoomJoin = eiJoin
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    39
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    40
    transformField LobbyChatMessage f = \c -> c{eiLobbyChat = f $ eiLobbyChat c}
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    41
    transformField EngineMessage f = \c -> c{eiEM = f $ eiEM c}
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    42
    transformField RoomJoin f = \c -> c{eiJoin = f $ eiJoin c}
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    43
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    44
    boundaries :: Event -> (Int, (NominalDiffTime, Int), (NominalDiffTime, Int), ([Action], [Action]))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    45
    boundaries LobbyChatMessage = (3, (10, 2), (30, 3), (chat1, chat2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    46
    boundaries EngineMessage = (8, (10, 4), (25, 5), (em1, em2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    47
    boundaries RoomJoin = (2, (10, 2), (35, 3), (join1, join2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    48
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    49
    chat1 = [Warning $ loc "Warning! Chat flood protection activated"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    50
    chat2 = [ByeClient $ loc "Excess flood"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    51
    em1 = [Warning $ loc "Game messages flood detected - 1"]
11466
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11046
diff changeset
    52
    em2 = [ByeClient $ loc "Excess flood"]
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    53
    join1 = [Warning $ loc "Warning! Joins flood protection activated"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    54
    join2 = [ByeClient $ loc "Excess flood"]
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    55
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    56
    doCheck ei = do
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    57
        curTime <- io getCurrentTime
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    58
        let (numPerEntry, (sec1, num1), (sec2, num2), (ac1, ac2)) = boundaries e
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    59
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    60
        let nei = takeWhile ((>=) sec2 . diffUTCTime curTime . snd) ei
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    61
        let l2 = length nei
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    62
        let l1 = length $ takeWhile ((>=) sec1 . diffUTCTime curTime . snd) nei
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    63
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    64
        let actions = if l2 >= num2 + 1 || l1 >= num1 + 1 then 
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    65
                ac2
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    66
                else
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    67
                if l1 >= num1 || l2 >= num2 then 
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    68
                    ac1
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    69
                    else
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    70
                    []
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    71
11466
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11046
diff changeset
    72
        return $ [ModifyClient . transformField e . const $ (numPerEntry, curTime) : nei
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11046
diff changeset
    73
                , ModifyClient (\c -> c{pendingActions = actions}) -- append? prepend? just replacing for now
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11046
diff changeset
    74
            ]
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    75
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    76
    updateInfo = return [
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    77
        ModifyClient $ transformField e
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    78
            $ \(h:hs) -> first (flip (-) 1) h : hs
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    79
        ]