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

package LATMOS::Accounts::Acls;

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

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

=head1 NAME

LATMOS::Accounts::Acls - Acl support in L<LATMOS::Accounts>

=head1 FUNCTIONS

=cut

=head2 new ($file)

Instanciate Acls from C<$file>

=cut

sub new {
    my ($class, $file) = @_;
    my $acls = bless(
        {
            _acls => [
                LATMOS::Accounts::Acls::Acl->new( '*.*', [ '@ROOT: read,write' ] ),
            ],
            _default_acls => [
                LATMOS::Accounts::Acls::Acl->new( '*.log', [ '$uid: read', '*: deny' ] ),
                LATMOS::Accounts::Acls::Acl->new(
                    'user.{userPasswd,userPassword,encryptedPassword,oldPassword}',
                    [ '$uid: write', '*: deny' ],
                ),
            ]
        }, $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 read permission and USER in form C<$...> for
C<@CREATE> 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

=head2 read_acl_file ($file)

Load acls from file C<$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;
}

=head2 add ($obj_dot_attr, $list)

A new acl for C<$obj_dot_attr> (in form C<object.attribute>) with C<$list>
permissions.

=cut

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

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

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

=cut

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

    foreach my $acl (@{$self->{_acls}}, @{$self->{_default_acls}}) {
        my $res = $acl->match($obj, $attr, $perm, $who, $groups, $base);
        if ( defined($res) ) {
            if ( $ENV{LA_ACL_DEBUG} ) {
                la_log(
                    LA_DEBUG,
                    "Acl: %s %s for %s by %s => %s :\n%s",
                    (ref $obj ? $obj->type . '/' . $obj->id : $obj),
                    $attr,
                    $perm,
                    $res,
                    $who,
                    $acl->dump,
                );
            }
            return $res;
        }
    }

    if ( $ENV{LA_ACL_DEBUG} ) {
        la_log(
            LA_DEBUG,
            "Acl: %s %s for %s => No match",
            ref $obj ? $obj->type . '/' . $obj->id : $obj,
            $attr,
            $perm,
        )
    }
    return 0;
}


=head2 dump

Return currently load acl as text

=cut

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

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Acls::Acl>

=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