view release on metacpan or  search on metacpan

lib/Plack/Middleware/Greylist.pm  view on Meta::CPAN

package Plack::Middleware::Greylist;

# ABSTRACT: throttle requests with different rates based on net blocks

# RECOMMEND PREREQ: Cache::FastMmap 1.52
# RECOMMEND PREREQ: Ref::Util::XS

use v5.20;
use warnings;

use parent qw( Plack::Middleware );

use HTTP::Status    qw/ HTTP_FORBIDDEN HTTP_TOO_MANY_REQUESTS /;
use List::Util 1.29 qw/ pairs /;
use Module::Load    qw/ load /;
use Net::IP::LPM;
use Plack::Util;
use Plack::Util::Accessor qw/ default_rate rules cache file _match greylist retry_after cache_config callback /;
use Ref::Util             qw/ is_plain_arrayref is_coderef /;
use Time::Seconds         qw/ ONE_MINUTE /;

use experimental qw/ postderef signatures /;

our $VERSION = 'v0.8.1';


sub prepare_app($self) {

    $self->default_rate(-1) unless defined $self->default_rate;

    die "default_rate must be a positive integer" unless $self->default_rate =~ /^[1-9][0-9]*$/;

    my $config = $self->cache_config;
    $self->cache_config( $config //= {} ) unless defined $config;

    $config->{init_file}                //= 0;
    $config->{unlink_on_exit}           //= !$config->{init_file};
    $config->{serializer}               //= '';
    my $expiry = $config->{expire_time} //= ONE_MINUTE;

    $self->retry_after( $config->{expire_time} + 1 ) unless defined $self->retry_after;
    die "retry_after must be a positive integer greater than $expiry seconds"
      unless $self->retry_after =~ /^[1-9][0-9]*$/ && $self->retry_after > $expiry;

    unless ( $self->cache ) {

        my $file = $self->file // $config->{share_file};
        die "No cache was set" unless defined $file;
        $config->{share_file} = "$file";

        load Cache::FastMmap;
        die "Cache::FastMmap version 1.52 or newer is required" if Cache::FastMmap->VERSION < 1.52;

        my $cache = Cache::FastMmap->new(%$config);

        $self->cache(
            sub($ip) {
                return $cache->get_and_set(
                    $ip,
                    sub( $, $count, $opts ) {
                        $count //= 0;
                        return ( $count + 1, { expire_on => $opts->{expire_on} } );
                    }
                );
            }
        );

    }

    my $match = Net::IP::LPM->new;

    $self->_match( sub($ip) { $match->lookup($ip) } );

    my @blocks;

    if ( my $greylist = $self->greylist ) {
        push @blocks, ( $greylist->%* );
    }