source: LATMOS-Accounts/lib/LATMOS/Accounts/Bases.pm @ 856

package LATMOS::Accounts::Bases;

use 5.010000;
use strict;
use warnings;
use LATMOS::Accounts::Bases::Objects;
use LATMOS::Accounts::Bases::Attributes;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Utils qw(exec_command to_ascii);

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

=head1 NAME

LATMOS::Accounts::Bases - Base class for account data bases

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('type', %options);
  ...

=head1 DESCRIPTION

This module provide basic functions for various account base

=head1 FUNTIONS

=cut

=head2 new($type, %options)

Return, if success, a new data base account object, $type is
account base type, %options to setup the base.

=cut

sub new {
    my ($class, $type, %options) = @_;

    my $pclass = ucfirst(lc($type));
    eval "require LATMOS::Accounts::Bases::$pclass;";
    if ($@) { return } # error message ?
    my $base = "LATMOS::Accounts::Bases::$pclass"->new(%options);
    $base->{_type} = lc($pclass);
    $base->{_label} = $options{label};
    $base->{_options} = { %options };
    $base->{wexported} = 0;
    $base->{defattr} = $options{defattr};
    $base->{_acls} = $options{acls};
    $base->{_allowed_values} = $options{allowed_values};
    la_log(LA_DEBUG, 'Instanciate base %s (%s)', ($options{label} || 'N/A'), $pclass);
    $base
}

sub wexported { unexported(@_) }

sub unexported {
    my ($self, $wexported) = @_;
    my $old = $self->{wexported};
    if (defined($wexported)) {
        $self->{wexported} = $wexported;
        $self->log(LA_DEBUG, "Switching exported mode: %s => %s", $old,
            $wexported);
    }
    return($old || 0);
}

sub log {
    my ($self, $level, $msg, @args) = @_;
    my $prefix = 'Base(' . $self->type . '/' . $self->label . ')';
    LATMOS::Accounts::Log::la_log($level, "$prefix $msg", @args);
}

sub label {
    $_[0]->{_label} || 'NoLabel';
}

sub type {
    $_[0]->{_type};
}

sub allowed_values {
    $_[0]->{_allowed_values}
}

sub obj_attr_allowed_values {
    my ($self, $otype, $attr) = @_;
    if ($self->allowed_values) {
        return $self->allowed_values->val("$otype.$attr", 'allowed');
    }
    return();
}

sub check_allowed_values {
    my ($self, $otype, $attr, $attrvalues) = @_;
    $self->allowed_values or return 1;
    my @values = ref $attrvalues ? @{ $attrvalues } : $attrvalues;
    foreach my $value (@values) {
        $value or next;
        if (my @allowed = $self->allowed_values->val("$otype.$attr", 'allowed')) {
            grep { $value eq $_ } @allowed or do {
                $self->log(LA_ERR,
                    "value `%s' is not allow for %s.%s per configuration (allowed_values)",
                    $value, $otype, $attr
                );
                return;
            };
        }
    }
    return 1;
}

sub _load_obj_class {
    my ($self, $otype) = @_;

    # finding perl class:
    my $pclass = ref $self;
    $pclass .= '::' . ucfirst(lc($otype));
    eval "require $pclass;";
    if ($@) {
        $self->log(LA_DEBUG, 'Cannot load perl class %s', $pclass);
        return
    } # error message ?
    return $pclass;
}

=head2 list_canonical_fields($otype, $for)

Return the list of supported fields by the database for object type $otype.

Optionnal $for specify the goal for which the list is requested, only supported
fields will be returns

=cut

sub list_canonical_fields {
    my ($self, $otype, $for) = @_;
    $for ||= 'rw';
    my $pclass = $self->_load_obj_class($otype) or return;
    sort $pclass->_canonical_fields($self, $for);
}

sub get_attr_schema {
    my ($self, $otype, $attribute) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    if ($pclass->can('_get_attr_schema')) {
        my $info = $pclass->_get_attr_schema($self, $attribute);
        return $info if ($info);
    }
    if ($self->can('_get_attr_schema')) {
        my $info = $self->_get_attr_schema($otype, $attribute);
        return $info if($info);
    }
    return {}
}

sub attribute {
    my ($self, $otype, $attribute) = @_;
    return LATMOS::Accounts::Bases::Attributes->new(
        $attribute,
        $self,
        $otype,
    );
}

sub delayed_fields {
    my ($self, $otype, $for) = @_;
    $for ||= 'rw';
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->_delayed_fields($self, $for);
}

=head2 get_field_name($otype, $c_fields, $for)

Return the internal fields name for $otype object for
canonical fields $c_fields

=cut

sub get_field_name {
    my ($self, $otype, $c_fields, $for) = @_;
    $for ||= 'rw';
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->_get_field_name($c_fields, $self, $for);
}

=head2 list_supported_objects(@otype)

Return a list of supported object

@type is an additionnal list of objects to check

=cut

sub list_supported_objects {
    my ($self, @otype) = @_;
    my %res;
    foreach my $inc (@INC) {
        my $sub = 'LATMOS::Accounts::Bases::' . ucfirst($self->type);
        $sub =~ s/::/\//g;
        foreach (glob("$inc/$sub/[A-Z]*.pm")) {
            s/.*\///;
            s/\.pm$//;
            $res{lc($_)} = 1;
        }
    }
    $res{$_} = 1 foreach(@otype);
    my @sobj = grep { $self->is_supported_object($_) } keys %res;
    la_log(LA_DEBUG, "Base %s supported objects: %s", $self->type, join(', ', @sobj));
    return @sobj;
}

=head2 is_supported_object($otype)

Return true is object type $otype is supported

=cut

sub is_supported_object {
    my ($self, $otype) = @_;
    return $self->_load_obj_class($otype) ? 1 : 0;
}

=head2 list_objects($otype)

Return the list of UID for object of $otype.

=cut

sub list_objects {
    my ($self, $otype) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->list($self);
}

=head2 get_object($type, $id)

Return an object of $type (typically user or group) having identifier
$id.

=cut

sub get_object {
    my ($self, $otype, $id) = @_;

    return LATMOS::Accounts::Bases::Objects->_new($self, $otype, $id);
}

=head2 create_object($type, $id, %data)

Create and return an object of type $type with unique id
$id having %data.

This method should be provided by the data base handler.

=cut

sub create_object {
    my ($self, $otype, $id, %data) = @_;
    my $pclass = $self->_load_obj_class($otype);
    if ($pclass->_create($self, $id, %data)) {
        la_log(LA_INFO,
            'Object %s (%s) created in base %s (%s)',
            $id, $otype, $self->label, $self->type
        );
    } else {
        la_log(LA_ERR,
            'Object creation %s (%s) in base %s (%s) failed',
            $id, $otype, $self->label, $self->type
        );
        return;
    };
    $self->get_object($otype, $id);
}

=head2 create_c_object($type, $id, %data)

Create and return an object of type $type with unique id
$id having %data using canonical fields

=cut

sub create_c_object {
    my ($self, $otype, $id, %cdata) = @_;
    $self->check_acl($otype, '@CREATE', 'w') or do {
        $self->log(LA_WARN, 'permission denied to create object type %s',
            $otype);
        return;
    };
    if (my $chk = (lc($otype) eq 'user' || lc($otype) eq 'group')
        ? LATMOS::Accounts::Utils::check_ug_validity($id)
        : LATMOS::Accounts::Utils::check_oid_validity($id)) {
        $self->log(LA_ERR, "Cannot create $otype with ID $id `%s:'", $chk);
        return;
    }
    foreach my $cfield (keys %cdata) {
        $self->check_allowed_values($otype, $cfield, $cdata{$cfield}) or do {
            $self->log(LA_ERR, "Cannot create $otype, wrong value");
            return;
        };
    }

    $self->_create_c_object($otype, $id, %cdata);
}

sub _create_c_object {
    my ($self, $otype, $id, %cdata) = @_;

    # populating default value
    foreach my $def (keys %{ $self->{defattr} || {}}) {
        if ($def =~ /^$otype\.(.*)$/) {
            $cdata{$1} = $self->{defattr}{$def} if(!$cdata{$1});
        }
    }
    if (lc($otype) eq 'user') {
        $cdata{homeDirectory} ||= $self->{defattr}{'user.homebase'} ?
            $self->{defattr}{'user.homebase'} . "/$id" : '';
        $cdata{uidNumber} ||= $self->find_next_numeric_id('user', 'uidNumber',
            $self->{defattr}{'user.min_uid'}, $self->{defattr}{'user.max_uid'});
        my $mailid = $cdata{givenName} && $cdata{sn}
            ? sprintf('%s.%s',
                to_ascii(lc($cdata{givenName})),
                to_ascii(lc($cdata{sn})),)
            : undef;

        if ($mailid &&
            $self->is_supported_object('aliases') &&
            ! $self->get_object('aliases', $mailid)) {
            if ($self->get_field_name($otype, 'mail', 'write')) {
                if ($self->{defattr}{'user.maildomain'}) {
                    $cdata{mail} ||= sprintf('%s@%s',
                    $mailid,
                    $self->{defattr}{'user.maildomain'});
                }
            }
            if ($self->get_field_name($otype, 'aliases', 'write')) {
                $cdata{aliases} ||= $mailid;
            }
            if ($self->get_field_name($otype, 'revaliases', 'write')) {
                $cdata{revaliases} ||= $mailid;
            }
        }
    } elsif (lc($otype) eq 'group') {
        $cdata{gidNumber} ||= $self->find_next_numeric_id('group', 'gidNumber',
            $self->{defattr}{'group.min_gid'}, $self->{defattr}{'group.max_gid'});
    }
    my %data;
    foreach my $cfield (keys %cdata) {
        my $field = $self->get_field_name($otype, $cfield, 'write') or next;
        $data{$field} = $cdata{$cfield};
    }
    keys %data or return 0; # TODO: return an error ?
    $self->create_object($otype, $id, %data);
}

=head2 delete_object($otype, $id)

Destroy from data base object type $otype having id $id.

=cut

sub delete_object {
    my ($self, $otype, $id) = @_;
    my $obj = $self->get_object($otype, $id) or do {
        $self->log(LA_WARN, 'Cannot delete %s/%s: no such object',
            $otype, $id);
        return;
    };
    $self->check_acl($obj, '@DELETE', 'w') or do {
        $self->log(LA_WARN, 'permission denied to delete %s/%s',
            $otype, $id);
        return;
    };
    $self->_delete_object($otype, $id);
}

sub _delete_object {
    my ($self, $otype, $id) = @_;
    my $pclass = $self->_load_obj_class($otype);
    $pclass->_delete($self, $id);
}

=head2 rename_object($otype, $id, $newid)

Rename an object.

=cut

sub rename_object {
    my ($self, $otype, $id, $newid) = @_;

    my $obj = $self->get_object($otype, $id) or do {
        $self->log(LA_WARN, 'Cannot rename %s/%s: no such object',
            $otype, $id);
        return;
    };
    if (my $chk = (lc($otype) eq 'user' || lc($otype) eq 'group')
        ? LATMOS::Accounts::Utils::check_ug_validity($id)
        : LATMOS::Accounts::Utils::check_oid_validity($id)) {
        $self->log(LA_ERR, "Cannot rename $otype/$id to ID $newid `%s:'", $chk);
        return;
    }
    $self->check_acl($obj, '@DELETE', 'w') &&
    $self->check_acl($obj, '@CREATE', 'w') or do {
        $self->log(LA_WARN, 'permission denied to rename %s/%s',
            $otype, $id);
        return;
    };

    $self->_rename_object($otype, $id, $newid);
}

sub _rename_object {
    my ($self, $otype, $id, $newid) = @_;
    my $pclass = $self->_load_obj_class($otype);
    $pclass->can('_rename') or do {
        $self->log(LA_ERR, 'rename object type %s is unsupported', $otype);
        return;
    };
    $pclass->_rename($self, $id, $newid);
}

=head2 load

Make account base loading data into memory if need.
Should always be called, if database fetch data on the fly
(SQL, LDAP), the function just return True.

=cut

sub load { 1 }

=head2 is_transactionnal

Return True is the database support commit and rollback

=cut

sub is_transactionnal {
    my ($self) = @_;
    return($self->can('_rollback') && $self->can('_commit'));
}

=head2 commit

Save change into the database if change are not done immediately.
This should always be called as you don't know when change are applied.

Return always true if database does not support any transaction.

The driver should provides a _commit functions to save data.

=cut

sub commit {
    my ($self) = @_;
    if ($self->can('_commit')) {
        la_log(LA_DEBUG, 'Commiting data');
        if (!(my $res = $self->_commit)) {
            la_log(LA_ERR, "Commit error on %s", $_->label);
            return $res;
        }
    }
    return 1;
}

=head2 rollback

If database support transaction, rollback changes. Return false
if database does not support.

If supported, driver should provides a _rollback functions

=cut

sub rollback {
    my ($self) = @_;
    if ($self->can('_rollback')) {
       la_log(LA_DEBUG, 'Rolling back data');
       return $self->_rollback;
   } else {
       return 0;
   }
}

=head2 current_rev

Return the current revision of the database

Must be provide by base driver if incremental synchro is supported

=cut

sub current_rev { return }

=head2 list_objects_from_rev($otype, $rev)

Return the list of UID for object of $otype.

=cut

sub list_objects_from_rev {
    my ($self, $otype, $rev) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    if (defined($rev) && $pclass->can('list_from_rev')) {
        return $pclass->list_from_rev($self, $rev);
    } else {
        # no support, return all objects...
        return $self->list_objects($otype);
    }
}

sub sync_object_from {
    my ($self, $srcbase, $otype, $id, %options) = @_;

    # is the object type supported by both
    foreach ($self, $srcbase) {
        $_->is_supported_object($otype) or return '';
    }
    
    if (my $srcobj = $srcbase->get_object($otype, $id)) {
        return $self->sync_object($srcobj, %options);
    } elsif (!$options{nodelete}) {
        $self->_delete_object($otype, $id) and return 'DELETED';
    }
    return;
}

=head2 sync_object

Synchronise an object into this base

=cut

sub sync_object {
    my ($self, $srcobj, %options) = @_;
    $self->is_supported_object($srcobj->type) or return '';
    my @fields = $options{attrs}
        ? @{ $options{attrs} }
        : $self->list_canonical_fields($srcobj->type, 'w');
    my %data;
    my %delayed = map { $_ => 1 } $self->delayed_fields($srcobj->type);
    foreach (@fields) {
        $srcobj->get_field_name($_, 'r') or next;
        if (! $options{onepass}) {
            if ($options{firstpass}) {
                $delayed{$_} and next;
            } else {
                $delayed{$_} or next;
            }
        }
        $data{$_} = $srcobj->_get_c_field($_);
    }
    keys %data or return '';
    if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id)) {
        my $res = $dstobj->_set_c_fields(%data);
        if (defined $res) {
            return $res ? 'SYNCED' : '';
        } else {
            return;
        }
    } elsif(!$options{nocreate}) {
        if ((! $options{firstpass}) && (!$options{onepass})) {
            $self->log(LA_ERR, 'This is not first pass, creation wanted but denied');
            return;
        }
        if ($self->_create_c_object($srcobj->type, $srcobj->id, %data)) {
            return 'CREATED'
        } else {
            return;
        }
    } else {
        # No error, but creation is denied
        return 'Creation skipped';
    }

    return;
}

=head2 search_objects($otype, %filter)

Search object according %filter. %filter is a list
of field/value which should match.

A default function is provided but each db driver can provide
an optimize version.

=cut

sub search_objects {
    my ($self, $otype, @filter) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->search($self, @filter);
}

sub attributes_summary {
    my ($self, $otype, $attr) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->attributes_summary($self, $attr);
}

sub find_next_numeric_id {
    my ($self, $otype, $field, $min, $max) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->find_next_numeric_id($self, $field, $min, $max);
}

sub authenticate_user {
    my ($self, $username, $passwd) = @_;
    $username or return;
    my $uobj = $self->get_object('user', $username) or do {
        la_log(LA_ERR, "Cannot authenticate non existing user $username");
        return;
    };

    if ($self->get_field_name('user', 'exported', 'r')) {
        if (!$uobj->_get_c_field('exported')) {
            la_log(LA_ERR, "User $username found but currently unexported");
            return;
        }
    }

    if (my $expire = $uobj->_get_c_field('shadowExpire')) {
        if ($expire > 0 && $expire < int(time / ( 3600 * 24 ))) {
            la_log(LA_ERR, "Account $username has expired (%d / %d)",
                $expire, int(time / ( 3600 * 24 )));
            return;
        }
    }

    if ($uobj->_get_c_field('locked')) {
        la_log(LA_ERR, "Account $username is currently locked");
        return;
    }

    my $password = $uobj->_get_c_field('userPassword') or do {
        la_log(LA_ERR, "Cannot authenticate user $username having no passwd");
        return;
    };
    if ($password eq crypt($passwd, $password)) { # crypt unix
        la_log(LA_NOTICE, "User $username authenticated");
        return 1;
    } else {
        la_log(LA_ERR, "Cannot authenticate user $username");
        return 0;
    }
}

sub connect {
    my ($self, $username, $password) = @_;
    my $auth = $self->authenticate_user($username, $password);
    if ($auth) {
        $self->{_user} = $username;
        la_log(LA_DEBUG, "Connected as $username");
    }
    return $auth;
}

sub check_acl {
    my ($self, $obj, $attr, $perm) = @_;
    if ($self->{_acls}) {
        my ($who, $groups) = ($self->{_user} || '');
        if ($who && (my $uo = $self->get_object('user', $who))) {
            $groups = [ $uo->_get_attributes('memberOf') ];
        } else {
            $who = '';
        }
        my $res = $self->{_acls}->check($obj, $attr, $perm, $who, $groups);
        $self->log(LA_INFO, 'permission denied for "%s" to get %s.%s for %s',
           $who, ref $obj ? $obj->id . '(' . $obj->type . ')' : $obj, $attr, $perm) if (!$res);
        return $res;
    } else {
        # No acls, woot
        return 1;
    }
}

sub text_empty_dump {
    my ($self, $fh, $otype, $options) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->text_dump($fh, $options, $self);
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 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