gameServer/FloodDetection.hs
author nemo
Sun, 27 Jul 2014 22:47:52 -0400
changeset 10370 8676ef16c594
parent 10095 003fc694c0c3
child 10464 d08611b52000
permissions -rw-r--r--
Using blended makes smilies and CJK less hideous.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
     1
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
     2
module FloodDetection where
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
     3
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
     4
import Control.Monad.State.Strict
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
     5
import Data.Time
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
     6
import Control.Arrow
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
     7
----------------
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
     8
import ServerState
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
     9
import CoreTypes
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    10
import Utils
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents:
diff changeset
    11
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    12
registerEvent :: Event -> StateT ServerState IO [Action]
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    13
registerEvent e = do
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    14
    eventInfo <- client's $ einfo e
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    15
    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
    16
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    17
    where
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    18
    einfo LobbyChatMessage = eiLobbyChat
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    19
    einfo EngineMessage = eiEM
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    20
    einfo RoomJoin = eiJoin
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    21
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    22
    transformField LobbyChatMessage f = \c -> c{eiLobbyChat = f $ eiLobbyChat c}
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    23
    transformField EngineMessage f = \c -> c{eiEM = f $ eiEM c}
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    24
    transformField RoomJoin f = \c -> c{eiJoin = f $ eiJoin c}
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    25
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    26
    boundaries :: Event -> (Int, (NominalDiffTime, Int), (NominalDiffTime, Int), ([Action], [Action]))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    27
    boundaries LobbyChatMessage = (3, (10, 2), (30, 3), (chat1, chat2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    28
    boundaries EngineMessage = (8, (10, 4), (25, 5), (em1, em2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    29
    boundaries RoomJoin = (2, (10, 2), (35, 3), (join1, join2))
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    30
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    31
    chat1 = [Warning $ loc "Warning! Chat flood protection activated"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    32
    chat2 = [ByeClient $ loc "Excess flood"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    33
    em1 = [Warning $ loc "Game messages flood detected - 1"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    34
    em2 = [Warning $ loc "Game messages flood detected - 2"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    35
    join1 = [Warning $ loc "Warning! Joins flood protection activated"]
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    36
    join2 = [ByeClient $ loc "Excess flood"]
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    37
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    38
    doCheck ei = do
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    39
        curTime <- io getCurrentTime
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    40
        let (numPerEntry, (sec1, num1), (sec2, num2), (ac1, ac2)) = boundaries e
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    41
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    42
        let nei = takeWhile ((>=) sec2 . diffUTCTime curTime . snd) ei
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    43
        let l2 = length nei
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    44
        let l1 = length $ takeWhile ((>=) sec1 . diffUTCTime curTime . snd) nei
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    45
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    46
        let actions = if l2 >= num2 + 1 || l1 >= num1 + 1 then 
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    47
                ac2
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    48
                else
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    49
                if l1 >= num1 || l2 >= num2 then 
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    50
                    ac1
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    51
                    else
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    52
                    []
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    53
10095
003fc694c0c3 Actually do some actions when flood detected
unc0rr
parents: 10094
diff changeset
    54
        return $ (ModifyClient . transformField e . const $ (numPerEntry, curTime) : nei) : actions
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
    updateInfo = return [
10094
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    57
        ModifyClient $ transformField e
d3a2fe9f04f2 Define some boundaries to detect events
unc0rr
parents: 10093
diff changeset
    58
            $ \(h:hs) -> first (flip (-) 1) h : hs
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10090
diff changeset
    59
        ]