9977

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
