File Coverage

blib/lib/Algorithm/FloodControl.pm

Criterion	Covered	Total	%
statement	79	106	74.5
branch	2	12	16.6
condition	3	8	37.5
subroutine	15	17	88.2
pod	7	7	100.0
total	106	150	70.6

package Algorithm::FloodControl;

use strict;
use warnings;
use utf8;
use 5.008000;

use Carp;
use Params::Validate qw/:all/;
use base 'Class::Accessor::Fast';
use Exporter 'import';
use Module::Load;

use version; our $VERSION = qv("2.01")->numify;
our @EXPORT = qw(
  flood_check
  flood_storage
);

# $Id: FloodControl.pm 7 2008-11-06 12:51:33Z gugu $
# $Source$
# $HeadURL: file:///var/svn/Algorithm-FloodControl/lib/Algorithm/FloodControl.pm $

__PACKAGE__->mk_accessors(qw/backend_name storage limits/);

my %FLOOD = ();

sub flood_check {
    my $fc = shift;    # max flood events count
    my $fp = shift;    # max flood time period for $fc events
    my $en = shift;    # event name (key) which identifies flood check data

    if ( !$en ) {
        my ( $p, $f, $l ) = caller;    # construct event name by:
        $en = "$p:$f:$l";              # package + filename + line
                                       # print STDERR "EN: $en\n";
    }

    $FLOOD{$en} ||= [];                # make empty flood array for this event name
    my $ar = $FLOOD{$en};              # get array ref for event's flood array
    my $ec = @{$ar};                   # events count in the flood array

    if ( $ec >= $fc ) {

        # flood array has enough events to do real flood check
        my $ot = $ar->[0];             # oldest event timestamp in the flood array
        my $tp = time() - $ot;         # time period between current and oldest event

        # now calculate time in seconds until next allowed event
        my $wait = int( ( $ot + ( $ec * $fp / $fc ) ) - time() );
        if ( $wait > 0 ) {

            # positive number of seconds means flood in progress
            # event should be rejected or postponed
            # print "WARNING: next event will be allowed in $wait seconds\n";
            return $wait;
        }

        # negative or 0 seconds means that event should be accepted
        # oldest event is removed from the flood array
        shift @{$ar};
    }

    # flood array is not full or oldest event is already removed
    # so current event has to be added
    push @{$ar}, time();

    # event is ok
    return 0;
}

sub flood_storage {
    if (@_) {
        if ( ref( $_[0] ) ne 'HASH' ) {
            croak "flood_storage sub requires hash reference as single argument"
        }
        %FLOOD = %{ $_[0] };
    }
    return \%FLOOD;
}

################# OOP ###########################

sub new {
    my $class  = shift;
    my $params = validate @_,
      {
        storage      => { type => OBJECT },
        backend_name => { type => SCALAR, optional => 1 },
        limits       => { type => HASHREF }
      };
    my $self = $class->SUPER::new($params);

    # be default backend will be selected by storage classname. but you can override it
    my $backend_name = __PACKAGE__ . '::Backend::' . ( $self->{backend_name} || ref $self->storage );
    load $backend_name;
    $self->backend_name($backend_name);
    return $self;
}

sub is_user_overrated {
    my ( $self, @params ) = @_;
    my ( $limit, $identifier ) = validate_pos @params, { type => SCALAR }, { type => SCALAR };
    my @configs     = @{ $self->{limits}{$limit} };
    my $max_timeout = 0;
    foreach my $config (@configs) {
        my $prefix  = __PACKAGE__ . '_rc_' . "$identifier|$limit|$config->{period}";
        my $backend = $self->backend_name->new(
            {
                storage => $self->storage,
                expires => $config->{period},
                prefix  => $prefix
            }
        );
        my $info = $backend->get_info( $config->{attempts} );
        if ( $info->{size} >= $config->{attempts} && $info->{timeout} > $max_timeout ) {
            $max_timeout = $info->{timeout};
        }
    }
    return $max_timeout;
}

sub get_attempt_count {
    my $self = shift;
    my ( $limit, $identifier ) = validate_pos @_, { type => SCALAR }, { type => SCALAR };
    my %attempts;
    my @configs = @{ $self->{limits}{$limit} };
    foreach my $config (@configs) {
        my $prefix = __PACKAGE__ . '_rc_' . "$identifier|$limit|$config->{period}";
        my $queue  = $self->backend_name->new(
            {
                storage => $self->storage,
                expires => $config->{period},
                prefix  => $prefix
            }
        );
        $attempts{ $config->{period} } = $queue->get_info( $config->{attempts} )->{size};
    }
    return \%attempts;
}

sub register_attempt {
    my $self = shift;
    my ( $limit, $identifier ) = validate_pos @_, { type => SCALAR }, { type => SCALAR };
    my @configs      = @{ $self->{limits}{$limit} };
    my $is_overrated = $self->is_user_overrated(@_);
    foreach my $config (@configs) {
        my $prefix = __PACKAGE__ . '_rc_' . "$identifier|$limit|$config->{period}";
        my $queue  = $self->backend_name->new(
            {
                storage => $self->storage,
                expires => $config->{period},
                prefix  => $prefix
            }
        );
        $queue->increment;
    }
    return $is_overrated;
}

sub forget_attempts {
    my $self = shift;
    my ( $limit, $identifier ) = validate_pos @_, { type => SCALAR }, { type => SCALAR };
    my @configs      = @{ $self->{limits}{$limit} };
    my $is_overrated = $self->is_user_overrated(@_);
    foreach my $config (@configs) {
        my $prefix = __PACKAGE__ . '_rc_' . "$identifier|$limit|$config->{period}";
        my $queue  = $self->backend_name->new(
            {
                storage => $self->storage,
                expires => $config->{period},
                prefix  => $prefix
            }
        );
        $queue->clear;
    }
    return $is_overrated;
}

1;

__END__