Authorization-AccessControl

 view release on metacpan or  search on metacpan

lib/Authorization/AccessControl.pm  view on Meta::CPAN

# ABSTRACT: Hybrid RBAC/ABAC access control

use Authorization::AccessControl::ACL;

use experimental qw(signatures);

use Exporter 'import';

our @EXPORT_OK = qw(acl);

sub acl() {
  state $acl = Authorization::AccessControl::ACL->new();
  $acl;
}

=head1 NAME

Authorization::AccessControl - hybrid RBAC/ABAC access control

=head1 SYNOPSIS

lib/Authorization/AccessControl/ACL.pm  view on Meta::CPAN

# ABSTRACT: Access Control List of granted privileges

use Authorization::AccessControl::Grant;
use Authorization::AccessControl::Request;
use List::Util qw(any);
use Readonly;

use experimental qw(signatures);

sub new($class, %params) {
  my $base = delete($params{base});
  my $role = delete($params{role});

  die("Unsupported params: ", join(', ', keys(%params))) if (keys(%params));

  Readonly::Hash1 my %hooks => (
    on_permit => [],
    on_deny   => []
  );

  Readonly::Hash1 my %data => (
    _base   => $base,
    _role   => $role,
    _grants => ($base ? undef : []),        # prevent privs from being saved in non-base instances
    _hooks  => ($base ? undef : \%hooks),
  );
  bless(\%data, $class);
}

sub hook($self, $type, $sub) {
  push($self->_base_instance->{_hooks}->{$type}->@*, $sub);
}

sub clone($self) {
  my $clone = __PACKAGE__->new();
  push($clone->{_grants}->@*,      $self->{_grants}->@*);
  push($clone->{_hooks}->{$_}->@*, $self->{_hooks}->{$_}->@*) foreach (keys($self->{_hooks}->%*));
  return $clone;
}

sub _base_instance($self) {
  $self->{_base} // $self;
}

sub role($self, $role = undef) {
  return __PACKAGE__->new(base => $self->_base_instance, role => $role);
}

sub grant($self, $resource, $action, $restrictions = undef) {
  my $p = Authorization::AccessControl::Grant->new(
    role         => $self->{_role},
    resource     => $resource,
    action       => $action,
    restrictions => $restrictions,
  );
  if (any {$p->is_equal($_)} $self->_base_instance->{_grants}->@*) {
    warn("skipping duplicate grant: $p\n");
  } else {
    push($self->_base_instance->{_grants}->@*, $p);
  }
  return $self;
}

sub __contains($arr, $v) {
  return 0 unless (defined($v));
  any {$_ eq $v} $arr->@*;
}

sub get_grants($self, %filters) {
  my @grants = $self->_base_instance->{_grants}->@*;
  @grants = grep {$_->resource eq $filters{resource}} @grants                          if (exists($filters{resource}));
  @grants = grep {$_->action eq $filters{action}} @grants                              if (exists($filters{action}));
  @grants = grep {__contains($filters{roles}, $_->role) || !defined($_->role)} @grants if (exists($filters{roles}));
  return @grants;
}

sub request($self) {
  warn("Warning: Calling `roles` on the result of `role` or `grant` calls may not yield expected results\n") if ($self->{_base});
  return Authorization::AccessControl::Request->new(acl => $self->_base_instance);
}

sub _event($self, $type, $ctx) {
  $_->($ctx) foreach ($self->_base_instance->{_hooks}->{$type}->@*);
}

=head1 NAME

Authorization::AccessControl::ACL - Access Control List of granted privileges

=head1 SYNOPSIS

  use Authorization::AccessControl::ACL;

lib/Authorization/AccessControl/Dispatch.pm  view on Meta::CPAN

package Authorization::AccessControl::Dispatch 0.04;
use v5.26;
use warnings;

# ABSTRACT: Dispatch result/status appropriately following ACL request yield

use Readonly;

use experimental qw(signatures);

sub new($class, %params) {
  my $granted = delete($params{granted});
  $granted = !!$granted if (defined($granted));    #force into boolean/undef
  my $entity = delete($params{entity});
  undef($entity) unless ($granted);                # ensure we don't hold the protected value if access is not granted

  die("Unsupported params: ", join(', ', keys(%params))) if (keys(%params));

  Readonly::Hash1 my %data => (
    _granted => $granted,
    _entity  => $entity,
  );

  bless(\%data, $class);
}

sub granted($self, $sub) {
  $sub->($self->{_entity}) if ($self->{_granted});
  return $self;
}

sub denied($self, $sub) {
  $sub->() if (defined($self->{_granted}) && !$self->{_granted});
  return $self;
}

sub null($self, $sub) {
  $sub->() if (!defined($self->{_granted}));
  return $self;
}

sub is_granted($self) {
  return ($self->{_granted} // 0) != 0;
}

=head1 NAME

Authorization::AccessControl::Dispatch - Dispatch result/status appropriately 
following ACL request yield

=head1 SYNOPSIS

lib/Authorization/AccessControl/Grant.pm  view on Meta::CPAN

use Data::Compare;
use Readonly;
use Scalar::Util qw(looks_like_number);

use experimental qw(signatures);

use overload
  '""' => 'to_string';

sub new($class, %params) {
  my $role         = delete($params{role});
  my $resource     = delete($params{resource});
  my $action       = delete($params{action});
  my $restrictions = delete($params{restrictions});
  $restrictions = {} unless (defined($restrictions));

  die("Unsupported params: ", join(', ', keys(%params))) if (keys(%params));
  die("Role must be a non-empty string") if (defined($role) && (ref($role) || $role eq ''));
  die("Resource is required")           unless ($resource              && !ref($resource));
  die("Action is required")             unless ($action                && !ref($action));

lib/Authorization/AccessControl/Grant.pm  view on Meta::CPAN

  Readonly::Scalar my $data => {
    _role         => $role,
    _resource     => $resource,
    _action       => $action,
    _restrictions => $restrictions
  };

  bless($data, $class);
}

sub to_string($self, @params) {
  my $role         = $self->{_role} ? '[' . $self->{_role} . '] ' : '';
  my $restrictions = '';
  foreach (keys($self->{_restrictions}->%*)) {
    my $v;
    if    ($self->{_restrictions}->{$_})                    {$v = $self->{_restrictions}->{$_}}
    elsif (looks_like_number($self->{_restrictions}->{$_})) {$v = 0}
    else                                                    {$v = 'false'}
    $restrictions .= "$_=$v,";
  }
  chop($restrictions);
  $role . $self->{_resource} . ' => ' . $self->{_action} . '(' . $restrictions . ')';
}

sub role($self) {
  $self->{_role};
}

sub resource($self) {
  $self->{_resource};
}

sub action($self) {
  $self->{_action};
}

sub restrictions($self) {
  $self->{_restrictions};
}

sub _satisfies_role($self, @roles) {
  return 1 unless ($self->{_role});
  return (grep {$_ eq $self->{_role}} @roles) > 0;
}

sub _satisfies_resource($self, $resource) {
  return 0 unless (defined($resource));
  return $self->{_resource} eq $resource;
}

sub _satisfies_action($self, $action) {
  return 0 unless (defined($action));
  return $self->{_action} eq $action;
}

sub _satisfies_restrictions($self, $attributes) {
  my %attrs = $attributes->%*;
  delete($attrs{$_}) foreach (grep {!exists($self->{_restrictions}->{$_})} keys(%attrs));
  my $v = Compare($self->{_restrictions}, \%attrs);
  return $v;
}

sub is_equal($self, $priv) {
  return 0 unless (($self->role // '') eq ($priv->role // ''));
  return 0 unless ($self->resource eq $priv->resource);
  return 0 unless ($self->action eq $priv->action);
  return 0 unless (Compare($self->restrictions, $priv->restrictions));
  return 1;
}

sub accepts($self, %params) {
  my ($roles, $resource, $action, $attributes) = @params{qw(roles resource action attributes)};

  return 0 unless ($self->_satisfies_resource($resource));
  return 0 unless ($self->_satisfies_action($action));
  return 0 unless ($self->_satisfies_role(($roles // [])->@*));
  return 0 unless ($self->_satisfies_restrictions($attributes // {}));
  return 1;
}

=head1 NAME

lib/Authorization/AccessControl/Request.pm  view on Meta::CPAN

use Scalar::Util qw(looks_like_number);

use constant true  => !0;
use constant false => !1;

use experimental qw(signatures);

use overload
  '""' => \&to_string;

sub new($class, %params) {
  my $acl        = delete($params{acl});
  my $roles      = delete($params{roles});
  my $resource   = delete($params{resource});
  my $action     = delete($params{action});
  my $attributes = delete($params{attributes}) // {};
  my $get_attrs  = delete($params{get_attrs})  // undef;

  die("Unsupported params: ", join(', ', keys(%params))) if (keys(%params));
  die("acl is a required property") unless (defined($acl) && ref($acl) && $acl->isa('Authorization::AccessControl::ACL'));

lib/Authorization/AccessControl/Request.pm  view on Meta::CPAN

    _acl        => $acl,
    _roles      => $roles,
    _resource   => $resource,
    _action     => $action,
    _attributes => $attributes,
    _get_attrs  => $get_attrs,
  };
  bless($data, $class);
}

sub to_string($self, @params) {
  my $roles      = ($self->{_roles} // [])->@* ? '[' . join(',', ($self->{_roles} // [])->@*) . ']' : '';
  my $attributes = '';
  my $resource   = $self->{_resource} // '{NO_RESOURCE}';
  my $action     = $self->{_action}   // '{NO_ACTION}';
  foreach (keys($self->{_attributes}->%*)) {
    my $v;
    if    ($self->{_attributes}->{$_})                    {$v = $self->{_attributes}->{$_}}
    elsif (looks_like_number($self->{_attributes}->{$_})) {$v = 0}
    else                                                  {$v = 'false'}
    $attributes .= "$_=$v,";
  }
  chop($attributes);
  $roles . $resource . ' => ' . $action . '(' . $attributes . ')';
}

sub __properties($self) {
  (
    acl        => $self->{_acl},
    roles      => $self->{_roles},
    resource   => $self->{_resource},
    action     => $self->{_action},
    attributes => $self->{_attributes},
    get_attrs  => $self->{_get_attrs},
  )
}

sub with_roles($self, @roles) {
  return __PACKAGE__->new($self->__properties, roles => [@roles],);
}

sub with_action($self, $action) {
  return __PACKAGE__->new($self->__properties, action => $action,);
}

sub with_resource($self, $resource) {
  return __PACKAGE__->new($self->__properties, resource => $resource,);
}

sub with_attributes($self, $attrs) {
  return __PACKAGE__->new($self->__properties, attributes => {$self->{_attributes}->%*, $attrs->%*},);
}

sub with_get_attrs($self, $sub) {
  return __PACKAGE__->new($self->__properties, get_attrs => $sub,);
}

sub _applicable_grants($self) {
  return undef unless (defined($self->{_resource}));
  return undef unless (defined($self->{_action}));

  my @grants =
    grep {
    $_->accepts(
      roles      => $self->{_roles},
      resource   => $self->{_resource},
      action     => $self->{_action},
      attributes => $self->{_attributes},
    )
    } $self->{_acl}->get_grants;

  return \@grants;
}

sub precheck($self) {
  my $grants = $self->_applicable_grants;
  return false unless (defined($grants));

  return $grants->@* > 0;
}

sub permitted($self) {
  my $grants = $self->_applicable_grants;
  return false unless (defined($grants));

  if ($grants->@*) {
    $self->{_acl}->_event(on_permit => $grants->[0]);
    return true;
  }
  $self->{_acl}->_event(on_deny => $self);
  return false;
}

sub yield($self, $get_obj) {
  unless (defined($self->{_get_attrs})) {
    return Authorization::AccessControl::Dispatch->new(granted => false) unless ($self->permitted);
    my $obj = $get_obj->();
    return Authorization::AccessControl::Dispatch->new(granted => undef) unless (defined($obj));
    return Authorization::AccessControl::Dispatch->new(granted => true, entity => $obj);
  }
  my $obj = $get_obj->();
  return Authorization::AccessControl::Dispatch->new(granted => undef) unless (defined($obj));

  my $attrs = $self->{_get_attrs}->($obj);