1 {-# LANGUAGE BangPatterns #-}

     2 

     3 module JoinsMonitor(

     4     JoinsMonitor

     5     , newJoinMonitor

     6     , cleanup

     7     , joinsSentry

     8     ) where

     9 

    10 import qualified Data.Map as Map

    11 import Data.Time

    12 import Data.IORef

    13 import qualified Data.ByteString as B

    14 import Data.Maybe

    15 import Control.Monad

    16 

    17 newtype JoinsMonitor = JoinsMonitor (IORef (Map.Map B.ByteString [UTCTime]))

    18 

    19 

    20 newJoinMonitor :: IO JoinsMonitor

    21 newJoinMonitor = do

    22     ioref <- newIORef Map.empty

    23     return (JoinsMonitor ioref)

    24 

    25 

    26 cleanup :: JoinsMonitor -> UTCTime -> IO ()

    27 cleanup (JoinsMonitor ref) time = modifyIORef' ref f

    28     where

    29         f = Map.mapMaybe (\v -> let v' = takeWhile (\t -> diffUTCTime time t < 60*60) v in if null v' then Nothing else Just v')

    30 

    31 

    32 joinsSentry :: JoinsMonitor -> B.ByteString -> UTCTime -> IO Bool

    33 joinsSentry (JoinsMonitor ref) host time = do

    34     m <- readIORef ref

    35     let lastJoins = map (diffUTCTime time) $ Map.findWithDefault [] host m

    36     let last30sec = length $ takeWhile (< 30) lastJoins

    37     let last2min = length $ takeWhile (< 120) lastJoins

    38     let last10min = length $ takeWhile (< 600) lastJoins

    39     let pass = last30sec < 2 && last2min < 4 && last10min < 6

    40 

    41     when pass $ writeIORef ref $ Map.alter (Just . (:) time . fromMaybe []) host m

    42 

    43     return pass