view release on metacpan or  search on metacpan

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

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

# ABSTRACT: Constructs an ACL request and checks if it is accepted

use Authorization::AccessControl::Dispatch;
use Readonly;
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'));

  Readonly::Scalar my $data => {
    _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;