source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Acls/Acl.pm @ 2282

package LATMOS::Accounts::Acls::Acl;
use strict;
use warnings;

=head1 NAME

LATMOS::Accounts::Acls::Acl - Single acl entry

=head1 DESCRIPTION

Manage a single acl entry

=head1 FUNCTIONS

=head2 new ($objdotatt, $list)

Create new sub acl where C<$objdotatt> is object in form C<Object.Attribute> and
C<$list> the list of permission.

=cut

sub new {
    my ($class, $objdotatt, $list) = @_;
    my ($obj, $attr) = $objdotatt =~ /^([^.]+)\.(.*)/ or return;
    my @attrs = ($attr =~ /^\{(.*)\}$/)
        ? (split(/\s*,\s*/, $1))
        : ($attr);
    @attrs or return;
    my $acl = {
        obj => lc($obj),
        attr => [ map { lc } @attrs ],
        users => [], # user->{r} = 1
    };
    bless($acl, $class);
    foreach my $k (@{ $list || [] }) {
        $acl->add_perm($k) or return;
    }
    $acl
}

=head2 add_perm($perm)

Add a permission to this sub acl

=cut

sub add_perm {
    my ($self, $perm) = @_;
    my ($username, $perms) = $perm =~ /^\s*(\S*):\s*(.*)$/;
    $username && $perms or return;
    my $user = { user => $username };
    foreach (split(/\s*,\s*/, $perms)) {
        /^read$/i  and do { $user->{r} = 1; next; };
        /^write$/i and do { $user->{w} = 1; next; };
        /^deny$/i and do {
            # reseting...
            $user->{r} = 0;
            $user->{w} = 0;
            last; # we end here, life is hard
        };
        return;
    }
    push(@{$self->{users}}, $user);
    1
}

=head2 match($obj, $attr, $perm, $who, $groups)

Return true is this sub acl apply to C<$obj>/C<$attr> for C<$perm> by user
C<$who> in groups C<$groups>.

=cut

sub match {
    my ($self, $obj, $attr, $perm, $who, $groups) = @_;
    my $objtype = ref $obj ? lc($obj->type) : $obj;
    $attr = lc($attr);

    # Does this ACL series concern this object:
    if (!($self->{obj} eq '*' || $self->{obj} eq $objtype)) {
        return
    }
    # Does this ACL series concern this attribute:
    grep { $_ eq '*' || $_ eq $attr } @{$self->{attr}} or return;

    # Foreach user, testing if this permission match:
    foreach my $u (@{ $self->{users} }) {
        # Obj have attr eq login user
        if (substr($u->{user}, 0, 1) eq '$') { # check attr content
            if (ref $obj) {
                my $attribute = substr($u->{user}, 1);
                my $val = $obj->_get_c_field($attribute) or return;
                my @vals = ref $val ? (@{ $val }) : ($val);
                return $u->{$perm} if (defined($u->{$perm}) && grep { $_ eq $who } @vals);
            }
        # user is in group
        } elsif (substr($u->{user}, 0, 1) eq '%') { # group
            my $group = substr($u->{user}, 1);
            return $u->{$perm} if (defined($u->{$perm}) && grep { $group eq $_ } grep { $_ } @{$groups ||[]});
        # any user
        } elsif ($u->{user} eq '*' || $u->{user} eq $who) {
            # TODO deference alias for SQL base
            # $obj->base->get_objects(...) ?
            return $u->{$perm} if (defined($u->{$perm}));
        # any authenticated user
        } elsif (lc($u->{user}) eq '@authenticated' && $who) {
            return $u->{$perm} if (defined($u->{$perm}));
        # not login
        } elsif (lc($u->{user}) eq '@anonymous' && $who eq "") {
            return $u->{$perm} if (defined($u->{$perm}));
        }
    }
    return;
}

=head2 dump

Return a textual dump of the sub acl

=cut

sub dump {
    my ($self) = @_;
    my $dump = sprintf("%s.{%s}\n", $self->{obj}, join(', ', @{$self->{attr}}));
    foreach my $u (@{ $self->{users} }) {
        $dump .= sprintf("\t%s: %s\n",
            $u->{user},
            join(', ', ($u->{r} ? 'read' : ()), ($u->{w} ? 'write' : ())) ||
            'deny');
    }
    $dump
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Acls>

=head1 AUTHOR

Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009, 2010, 2011, 2012 by Thauvin Olivier

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut