source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts.pm @ 2459

package LATMOS::Accounts;

use 5.010000;
use strict;
use warnings;
use base qw(Config::IniFiles);
use LATMOS::Accounts::Bases;
use LATMOS::Accounts::Synchro;
use LATMOS::Accounts::SynchAccess;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Acls;
use LATMOS::Accounts::I18N;

our $VERSION = '6.1.2.0';

binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");

=head1 NAME

LATMOS::Accounts - Core module for LATMOS account management tools

=head1 DESCRITPTION

=cut

# Return the configuration directory according settings:
#
sub _configdir {
   my ($self) = @_;
   $ENV{LA_CONFIG} ||
   ($self || {})->{_configdir} ||
   '/etc/latmos-accounts'
}

=head1 FUNCTION

=head2 new($configdir, %options)

Instanciate a new LATMOS::Accounts object.

C<$configdir> if defined is the directory containing files to use,
default to F</etc/latmos-accounts/>.

C<%options> can contains:

=over 4

=item noacl

If true, acls configuration are not load and code act like everything is
allowed.

This flag is usefull for administrative tools, for which no acl must apply.

=back

=cut

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

    $config ||= _configdir();

    my $configfile = join('/', $config, 'latmos-accounts.ini');

    my $self = Config::IniFiles->new(
        -file => $configfile,
        '-default' => '_default_',
    ) or do {
        la_log(LA_ERR, 'Can\'t open main config file %s', $configfile);
        return;
    };

    $self->{_configdir} = $config;
    $self->{_loguser} = $options{loguser};
    bless($self, $class);

    unless ($options{noacl}) {
        if (-f (my $aclf = join('/', $self->_configdir, 'la-acls.ini'))) {
            $self->{_acls} = LATMOS::Accounts::Acls->new($aclf) or do {
                la_log(LA_ERR, 'Cannot load ACL file %s', $aclf);
                return;
            };
        }
    }

    if (-f (my $allowf = join('/', $self->_configdir, 'la-allowed-values.ini'))) {
        $self->{_allowed_values} = Config::IniFiles->new(
            -file => $allowf,
        ) or do {
            la_log(LA_ERR, 'Cannot load ALLOWED VALUES %s', $allowf);
            return;
        };
    }

    $self
}

=head2 list_bases

Return the base list found in config file

=cut

sub list_bases {
    my ($self) = @_;
    grep {
        !m/^_.*_$/ &&
        !m/^sync:/
    } $self->Sections
}

=head2 default_base_name

Return the default base name according config file

=cut

sub default_base_name {
    my ($self) = @_;
    $self->val('_default_', 'base', ($self->list_bases)[0]);
}

=head2 base($basename)

Return a L<LATMOS::Accounts::Base> object over base named $basename
defined in the config file.

The base is loaded by this function.

=cut

sub base {
    my ($self, $section) = @_;
    # this method perform a cache

    my $basename = $section || $self->default_base_name;

    my $base = $self->_load_base($basename) or do {
        la_log(LA_ERR, "%s didn't load", $basename);
        return;
    };

    $base->load or do {
        la_log(LA_ERR, "%s didn't load", $base->label);
        return;
    };
    $base;
}

=head2 LogUser

Return the username to use when no user is connected

=cut

sub LogUser {
    my ( $self, $Login ) = @_;

    my $name = $self->{_loguser} || '@Console';

    if ($Login) {
        $self->{_loguser} = $Login;
    }

    return $name;
}

# do the bad work
sub _load_base {
    my ($self, $section) = @_;
    my $type = $self->val($section, 'type') or return;
    la_log(LA_DEBUG, "Trying to load base %s", $section);

    my %params = ();

    foreach ( $self->Parameters($section), $self->Parameters('_default_') ) {
        my ($val) = $self->val($section, $_);
        $params{ $_ } = $val;
    }
 
    my %defattr = ();

    foreach ( $self->Parameters('_defattr_') ) {
        my ($val) = $self->val( '_defattr_', $_ );
        $defattr{ $_ } = $val;
    }

    $params{monitored} = {};
    foreach my $item ($self->val($section, 'monitored')) {
        $params{monitored}{lc($item)} = 1;
    }

    my $base = LATMOS::Accounts::Bases->new(
        $type,
        {
            params => \%params,
            label => $section,
            acls => $self->{_acls},
            allowed_values => $self->{_allowed_values},
            configdir => $self->_configdir,
            la => $self,
            defattr => { %defattr },
        },
    ) or do {
        la_log(LA_WARN, "Cannot instanciate base $section ($type)");
        return;
    };
}

=head2 list_synchro

List synchronisation setup in L<latmos-accounts.ini>

=cut

sub list_synchro {
    my ($self) = @_;
    grep { $_ } map { /^sync:(.*)$/; $1 } $self->Sections
}

=head2 default_synchro_name

Return de default synchronisation name

=cut

sub default_synchro_name {
    my ($self) = @_;
    $self->val('_default_', 'sync');
}

=head2 default_synchro

Return a reference to default synchronisation object

=cut

sub default_synchro {
    my ($self, %options) = @_;
    my $syncname = $self->default_synchro_name or do {
        la_log(LA_ERR, 'Cannot find default synchro in config');
        return;
    };
    $self->create_synchro($syncname, %options);
}

=head2 create_synchro($name, %options)

Return a reference to synchronisation object for C<$name> synchronisation.

=cut

sub create_synchro {
    my ($self, $name, %options) = @_;

    # taking options from config
    if ($name) {
        foreach my $param ($self->Parameters("sync:$name")) {
            if (!defined($options{$param})) {
                my @args = $self->val("sync:$name", $param);
                $options{$param} = ($args[1] || $param eq 'to')
                    ? [ @args ]
                    : $args[0];
            }
        }
    }

    my $labfrom = $options{from} ? $self->base($options{from}) : $self->base;

    my @labto =
        grep { $_ }
        map { $self->base($_) }
        @{ $options{to} || []}
        or do {
        la_log(LA_ERR, "No destination base load in this synchro");
        return;
    };

    my $sync = LATMOS::Accounts::Synchro->new(
        $labfrom, [ @labto ],
        state_dir => ($self->val('_default_', 'state_dir') || undef),
        %options,
        name => $name,
    );
}

sub _sync_from_name {
    my ($self, $syncname) = @_;
    return if (!$syncname);
    $self->val("sync:$syncname", 'from', $self->default_base_name);
}

=head2 sync_access($name, %options)

Return a L<LATMOS::Accounts::SynchAccess> object over C<$name> synchronisation.

=cut

sub sync_access {
    my ($self, $name, %options) = @_;

    my @obases;
    if ($name) {
        @obases =
        (map { $self->base($_) } ($self->_sync_from_name($name), $self->val("sync:$name", 'to')));
    } elsif(@{ $options{bases} || []}) {
        @obases = map { $self->base($_) } @{ $options{bases} || []};
    } elsif (my $sname = $self->default_synchro_name) {
        @obases = (map { $self->base($_) }
            ($self->_sync_from_name($sname), $self->val("sync:$sname", 'to'))
        );
    }

    if (!@obases) {
        la_log(LA_ERR, "Cannot load any bases for syncronised action");
        return;
    }

    la_log(LA_DEBUG, "Load databases: %s", join(', ', map { $_->label } @obases));

    LATMOS::Accounts::SynchAccess->new([ @obases ]);
}

=head2 call_batch_sync

Send signal to L<la-sync-manager> daemon to synchronize bases.

=cut

sub call_batch_sync {
    my ($self) = @_;
    if (my $sd = $self->val('_default_', 'state_dir')) {
        if (open(my $fh, '<', $sd . '/sync-manager.pid')) {
            my $pid = <$fh> || '';
            chomp($pid);
            close($fh);
            if ($pid && kill 1, $pid) {
                return 1; # \o/ we succeed
            } else {
                la_log(LA_ERR, "Can send signal -1 to la-sync-manager (pid: %s, %s)",
                    $pid || 'none', $!);
                return;
            }
        } else {
            la_log(LA_ERR, 'Cannot open la-sync-manager pid file');
            return;
        }
    } else {
        la_log(LA_WARN, "No statedir setup, cannot find la-sync-manager pid file");
        return;
    }
}

1;

__END__

=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