view release on metacpan or  search on metacpan

lib/Algorithm/FloodControl.pm  view on Meta::CPAN

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__

=pod

=head1 NAME

Algorithm::FloodControl - Limit event processing to count/time ratio.

=head1 SYNOPSIS

=head2 Functional interface

    use Algorithm::FloodControl;

    my $wait = flood_check( 5, 60, 'FLOOD EVENT NAME' );

    if( $wait ) {
        print "Please wait $wait sec. before requesting this resource again.";
    } else {
        print "Ok, here you are.";
    }  

=head2 Object-oriented interface

    use Algorithm::FloodControl ();

    my $flood_control = Algorithm::FloodControl->new(
        storage => $memd, 
        limits => {
            limit_name => [
                {
                    period => 60,
                    attempts => 5,
                }, {
                    period => 3600,
                    attempts => 30,
                }
            ]
        }
    );

    $flood_control->register_attempt( limit_name => 'vasja_pupkin' );