File Coverage

blib/lib/Mojolicious/Plugin/AccessControl.pm

Criterion	Covered	Total	%
statement	61	62	98.3
branch	22	28	78.5
condition	10	14	71.4
subroutine	12	12	100.0
pod	1	1	100.0
total	106	117	90.6

package Mojolicious::Plugin::AccessControl;
use strict;
use warnings;
our $VERSION = '0.04';

use Mojo::Base 'Mojolicious::Plugin';
use Net::CIDR::Lite;
use Carp ();

use constant CONDITION_NAME => 'access';

sub register {
    my ( $self, $app ) = @_;

    $app->routes->add_condition(
        CONDITION_NAME() => sub {
            my ( $r, $c, $cap, $args ) = @_;
            $args ||= [];

            my $opt = {};
            my @rule_list = @$args;

            if ( ref $args->[0] eq 'HASH' ) {
                $opt = $args->[0];

                # Remove option ref from rule list
                @rule_list = splice(@$args, 1);
            }

            if ( $opt->{on_deny} && ref $opt->{on_deny} ne 'CODE' ) {
                Carp::croak "on_deny must be a CODEREF";
            }

            $opt->{cache} = 1 unless ( defined $opt->{cache} );
            my $rules = ( $opt->{cache} )
                ? ( $r->{ __PACKAGE__ . '._rules' } ||= $self->_rules(@rule_list) ) # caches to Mojolicious::Routes::Route
                : $self->_rules(@rule_list);

            for my $rule (@$rules) {
                my ( $check, $allow ) = @{$rule};

                my $result = $check->($c);
                if ( defined $result && $result ) {

                    # denied
                    if ( !$allow && $opt->{on_deny} ) {
                        $opt->{on_deny}->($c);
                    }

                    return $allow;
                }
            }

            return 1;
        }
    );
}

sub _rules {
    my ($self, @args) = @_;

    my @rules;
    for ( my $i = 0; $i < @args; $i += 2 ) {
        my ( $allowing, $rule ) = ( $args[$i], $args[ $i + 1 ] );

        Carp::croak "must be allow or deny"
            unless $allowing =~ /^(allow|deny)$/;

        $allowing = ( $allowing eq 'allow' ) ? 1 : 0;
        my $check = $rule;

        if ( $rule =~ /^ALL$/i ) {
            $check = sub {1};
        }
        elsif ( $rule =~ /[A-Z]$/i ) {
            $check = sub {
                my $host = $_[0]->req->env->{'REMOTE_HOST'};
                return unless defined $host;    # skip
                return $host =~ /^(.*\.)?\Q${rule}\E$/;
            };
        }
        elsif ( ref($rule) ne 'CODE' ) {
            my $cidr = Net::CIDR::Lite->new();
            $cidr->add_any($rule);

            $check = sub {
                my $addr = $_[0]->tx->remote_address;
                if ( defined $addr ) {
                    return ( $cidr->find($addr) ) ? 1 : 0;
                }
            };
        }

        push @rules, [ $check => $allowing ];
    }

    return \@rules;
}

1;
__END__