source: LATMOS-Accounts/lib/LATMOS/Accounts/Acls.pm @ 479

package LATMOS::Accounts::Acls;

use strict;
use warnings;
use LATMOS::Accounts::Log;

our $VERSION = (q$Rev: 330 $ =~ /^Rev: (\d+) /)[0];

sub new {
    my ($class, $file) = @_;
    my $acls = bless(
        {
            _acls => []
        }, $class
    );
    if ($file) {
        $acls->read_acl_file($file) or return;
    }
    $acls
}

=head1 ACL FILE FORMAT

    OBJ_TYPE.ATTRIBUTE
        USER:  read,write
        USER2: read

=over 4

=item OBJ_TYPE is the type the object, '*' match all

=item ATTRIBUTE is either an attribute, either an comma separate attribute
enclose into bracket, either a '*' to match any attribute.

Special keyword C<@CREATE> and C<@DELETE> can be used to allow or deny object
creation and deletion. In this case USER in form C<$...> and read permission
have no effect (see below). C<*> do not include C<@CREATE> and C<@DELETE> action.

=item USER can be

=over 4

=item a username

=item group, prefixed by a '%'

=item an attribute of the accessed object which should contains the username,
prefixed by '$'

=item C<*> to math any user

=item @authenticated or @anonymous for any authenticated user and non
authenticated user ('*' include both)

=back

=item Permission are read and or write, or deny.

=back

ACL are applied in the order they appear in the file.

=cut

sub read_acl_file {
    my ($self, $file) = @_;

    my $acl;
    my $line_nb = 0;
    my $prevline = "";
    if (open(my $handle, '<', $file)) {
        while(my $realline = <$handle>) {
            $line_nb++;
            chomp($realline);
            if ($realline =~ /\\$/) {
                # continuation line
                $prevline .= $realline;
                $prevline =~ s/\s*\\$//;
                next;
            }
            my $line = $prevline . $realline; # keep track to report malformed file
            $prevline = "";
            $line =~ s/\s*#.*//;
            if ($line =~ /^(\S.*)/) {
                if ($acl) {
                    push(@{$self->{_acls}}, $acl);
                }
                $acl = LATMOS::Accounts::Acls::acl->new($1) or do {
                    la_log(LA_ERR, "Error in %s at line %d", $file,
                        $line_nb);
                    return;
                };
            } elsif ($line =~ /^\s+(\S.*)/) {
                if ($acl) {
                    $acl->add_perm($line) or do {
                        la_log(LA_ERR, "Error in %s at line %d", $file,
                            $line_nb);
                        return;
                    };
                } else {
                    # err no acl
                    return;
                }
            } elsif ($line =~ /^\s*$/) {
                # just empty line
            } else {
            }
        }
        if ($acl) {
            push(@{$self->{_acls}}, $acl);
        }
    } else {
        la_log(LA_ERR, "Cannot open acl file %s", $file);
        return;
    }
    1;
}

sub add {
    my ($self, $obj, $list) = @_;
    my $acl = LATMOS::Accounts::Acls::acl->new(
        $obj, $list) or return;
    push(@{$self->{_acls}}, $acl);
    return 1;
}

sub check {
    my ($self, $obj, $attr, $perm, $who, $groups) = @_;
    # Asking 'r' perm over create or delete has no sense:
    $attr =~ /^@(CREATE|DELETE)$/ && $perm eq 'r' and return;

    foreach my $acl (@{$self->{_acls}}) {
        my $res = $acl->match($obj, $attr, $perm, $who, $groups);
        defined($res) and return $res;
    }
    return 0;
}

sub dump {
    my ($self) = @_;
    foreach my $acl (@{$self->{_acls}}) {
        print $acl->dump, "\n";
    }
}

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

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
}

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
}

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 { ($_ !~ /^@(CREATE|DELETE)$/ && $_ 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);
                my @vals = ref $val ? (@{ $val }) : ($val);
                return ($u->{$perm} || 0) if (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} || 0) if (grep { $group eq $_ } @{$groups ||[]});
        # any user
        } elsif ($u->{user} eq '*' || $u->{user} eq $who) {
            return $u->{$perm} || 0;
        # any authenticated user
        } elsif (lc($u->{user}) eq '@authenticated' && $who) {
            return $u->{$perm} || 0;
        # not login
        } elsif (lc($u->{user}) eq '@anonymous' && $who eq "") {
            return $u->{$perm} || 0;
        }
    }
    return;
}

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__