gameServer/FloodDetection.hs
author sheepluva
Wed, 22 Mar 2023 09:54:30 +0100
changeset 15929 b6cd49768fc5
parent 14841 111c4d750c6d
permissions -rw-r--r--
This is an empty commit, for testing purposes.
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
14841
111c4d750c6d Limit room name change rate
unc0rr
parents: 11466
diff changeset
    39
    einfo RoomNameUpdate = eiLobbyChat
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    40
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    41
    transformField LobbyChatMessage f = \c -> c{eiLobbyChat = f $ eiLobbyChat c}
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    42
    transformField EngineMessage f = \c -> c{eiEM = f $ eiEM c}
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    43
    transformField RoomJoin f = \c -> c{eiJoin = f $ eiJoin c}
14841
111c4d750c6d Limit room name change rate
unc0rr
parents: 11466
diff changeset
    44
    transformField RoomNameUpdate f = transformField LobbyChatMessage f
111c4d750c6d Limit room name change rate
unc0rr
parents: 11466
diff changeset
    45
    
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    46
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    47
    boundaries :: Event -> (Int, (NominalDiffTime, Int), (NominalDiffTime, Int), ([Action], [Action]))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    48
    boundaries LobbyChatMessage = (3, (10, 2), (30, 3), (chat1, chat2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    49
    boundaries EngineMessage = (8, (10, 4), (25, 5), (em1, em2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    50
    boundaries RoomJoin = (2, (10, 2), (35, 3), (join1, join2))
14841
111c4d750c6d Limit room name change rate
unc0rr
parents: 11466
diff changeset
    51
    boundaries RoomNameUpdate = (\(a, b, c, _) -> (a, b, c, (roomName1, roomName2))) $ boundaries LobbyChatMessage
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    52
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    53
    chat1 = [Warning $ loc "Warning! Chat flood protection activated"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    54
    chat2 = [ByeClient $ loc "Excess flood"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    55
    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
    56
    em2 = [ByeClient $ loc "Excess flood"]
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    57
    join1 = [Warning $ loc "Warning! Joins flood protection activated"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    58
    join2 = [ByeClient $ loc "Excess flood"]
14841
111c4d750c6d Limit room name change rate
unc0rr
parents: 11466
diff changeset
    59
    roomName1 = [Warning $ loc "Warning! Room name change flood protection activated"]
111c4d750c6d Limit room name change rate
unc0rr
parents: 11466
diff changeset
    60
    roomName2 = [ByeClient $ loc "Excess flood"]
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    61
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    62
    doCheck ei = do
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    63
        curTime <- io getCurrentTime
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    64
        let (numPerEntry, (sec1, num1), (sec2, num2), (ac1, ac2)) = boundaries e
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    65
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    66
        let nei = takeWhile ((>=) sec2 . diffUTCTime curTime . snd) ei
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    67
        let l2 = length nei
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    68
        let l1 = length $ takeWhile ((>=) sec1 . diffUTCTime curTime . snd) nei
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    69
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    70
        let actions = if l2 >= num2 + 1 || l1 >= num1 + 1 then 
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    71
                ac2
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    72
                else
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    73
                if l1 >= num1 || l2 >= num2 then 
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    74
                    ac1
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    75
                    else
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    76
                    []
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    77
11466
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11046
diff changeset
    78
        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
    79
                , 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
    80
            ]
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    81
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    82
    updateInfo = return [
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    83
        ModifyClient $ transformField e
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    84
            $ \(h:hs) -> first (flip (-) 1) h : hs
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    85
        ]