source: trunk/LATMOS-Accounts-Web/lib/LATMOS/Accounts/Web/Model/Accounts.pm

package LATMOS::Accounts::Web::Model::Accounts;

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../../LATMOS-Accounts/lib";
use base 'Catalyst::Model';
use base 'LATMOS::Accounts';
use LATMOS::Accounts::Log;
use utf8;

la_set_log(
    syslog => [],
    console => LA_WARNING,
);

=head1 NAME

LATMOS::Accounts::Web::Model::Accounts - Catalyst Model

=head1 DESCRIPTION

Catalyst Model.

=cut

=head1 FUNCTIONS

=cut

sub new {
    my ($class) = @_;
    bless(LATMOS::Accounts
        ->new(LATMOS::Accounts::Web->config->{config}),
        $class);
}

sub ACCEPT_CONTEXT {
    my ($self, $c, $form, $object, $base) = @_;
    $self->{c} = $c;
    $self;
}

sub accounts {
    my ($self) = @_;
    $self;
}

sub db {
    my ($self) = @_;
    $self->{_default_base} and return $self->{_default_base};
    $self->{_default_base} = $self->base;
    $self->{_default_base}->SetCallBack(
        'commit',
        sub { $self->{c}->stash->{DBNeedSync} = 1; }
    );
    $self->{_default_base}->load or return;
    $self->{_default_base}->wexported(1);
    $self->{_default_base}
}

=head2 obj_to_label($ref)

Return a proper label to display for each object

=cut

sub obj_to_label {
    my ($self, $ref) = @_;
    my $uri_part = {
        user => 'Utilisateurs',
        group => 'Groupes',
        nethost => 'HÎtes réseaux',
        netzone => 'Zones réseau',
        site => 'Sites',
        aliases => 'Alias',
        service => 'Services',
        address => 'Adresse',
        employment => 'Statut',
        support => 'Support',
    }->{$ref};
}

sub obj_to_uri {
    my ($self, $ref, $id) = @_;
    my $uri_part = {
        user => 'users',
        group => 'groups',
        nethost => 'nethosts',
        netzone => 'netzones',
        site => 'sites',
        aliases => 'aliases',
        service => 'services',
        support => 'support',
    }->{$ref} || $ref;

    return $self->{c}->uri_for('/', $uri_part, ($id ? $id : ()));
}

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

    my @list = $self->db->list_objects($otype);
    my $prev;
    while (@list && ($list[0] || '') ne $id) {
        $prev = shift(@list);
    }
    return([ $prev, $list[1] ]);
}

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

    my @list = $self->db->search_objects($otype, @filter);

    my $i = 0;
    for($i = 0; $i <= $#list; $i++) {
        $list[$i] eq $id and last;
    }

    my %ptr = ();
    $ptr{oprev} = $list[$i-1] if ($i > 0);
    $ptr{'onext'} = $list[$i+1] if ($i < $#list);
    $ptr{ofirst} = $list[0] if ($i > 1);
    $ptr{'olast'} = $list[$#list] if ($i < $#list -1);
    $ptr{list} = \@list;

    return \%ptr;
}

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

    my $db = $self->db;

    if (!@otype) {
        @otype = $db->list_supported_objects;
    }

    foreach (@otype) {
        if (!$db->check_acl($_, '@CREATE', 'w')) {
            return;
        }
    }
    return 1;
}

# Such function must not be here, but in LATMOS::Accounts
# But code does not allow this at time
sub list_unowned_aliases {
    my ($self, $filter) = @_;
    my $db = $self->db;
    my $sth = $db->db->prepare_cached(q{
        select name, forward from aliases where
        name not in (select name from "user")
            and
        forward not in (select array[name] from "user")
    } . 
    ($filter 
        ? q{
            and (lower(name) ILIKE $1 or
            lower(array_to_string(forward, ',')) ILIKE $1)
          }
        : '')
    );

    $sth->execute($filter ? ('%' . $filter . '%') : ());
    my %aliases;
    while (my $res = $sth->fetchrow_hashref) {
        $aliases{$res->{name}} = $res->{forward};
    }
    return \%aliases
}

sub sync_access {
    my ($self) = @_;
    $self->SUPER::sync_access
}

sub sync {
    my ($self) = @_;
    $self->default_synchro()
}

sub ChangeUserPassword {
    my ($self, $username, $password, $force) = @_;

    my $base = $self->db;
    my $user = $base->get_object('user', $username) or do {
        return $self->{c}->localize('Cannot get user object [_1]', $username);
    };

    my $sync = $self->sync_access;

    # This is widelly burk:
    # synchaccess do not manage connect() at time, opening a
    # backdoor then :\
    foreach ($sync->bases) { $_->{_user} = $base->{_user} }

    my $suser = $sync->get_object_ifexists('user', $username);
    my $msg = $user->check_password($password);
    if ($msg ne 'ok' && !$force) {
        return $msg . ', ' .  $self->{c}->localize('Unchanged password');
    } elsif ($suser && $suser->_set_password($password)) {
        $sync->commit;
        return;
    } else {
        return $self->{c}->localize('Error while changing password');
    }
}

sub call_batch_sync {
    my ($self) = @_;

    $self->{c}->log->debug('Running call_batch_sync()');

    if (my $command = $self->{c}->config->{callSyncCmd}) {
        if (system($command) != 0) {
            $self->{c}->log->warn("Error while running callSyncCmd: $!");
        }
    } else {
        $self->SUPER::call_batch_sync;
    }

}

=head1 AUTHOR

Thauvin Olivier

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;