source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql.pm @ 1457

package LATMOS::Accounts::Bases::Sql;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Bases::Sql::DataRequest;
use DBI;
use Crypt::RSA;
use Crypt::RSA::Key::Public::SSH;
use Crypt::RSA::Key::Private::SSH;
use Crypt::RSA::Key::Public;
use Crypt::RSA::Key::Private;
use MIME::Base64;

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

sub SCHEMA_VERSION { 11 };

=head1 NAME

LATMOS::Ad - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('unix');
  ...

=head1 DESCRIPTION

Account base access over standard unix file format.

=head1 FUNCTIONS

=cut

=head2 SCHEMA_VERSION

Return the SQL schema version to use for this software version.

=head2 new(%config)

Create a new LATMOS::Ad object for windows AD $domain.

domain / server: either the Ad domain or directly the server

ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>.

=cut

sub new {
    my ($class, %config) = @_;
    
    my $base = {
        db_conn => $config{db_conn},
    };

    bless($base, $class);
}

sub DESTROY {
    my ($self) = @_;
    $self->{_db} && $self->{_db}->rollback;
}

=head2 db

Return a L<DBI> handle over database, load it if need.

=cut

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

    if ($self->{_db} && $self->{_db}->ping) {
        return $self->{_db};
    } else {
        $self->{_db} = DBI->connect_cached(
            'dbi:Pg:' . $self->{db_conn},
            undef, undef,
            {
                RaiseError => 0,
                AutoCommit => 0,
                PrintWarn => 1,
                PrintError => 1,
            }
        ) or do {
            $self->log(LA_ERR, "Cannot connect to database: %s", $DBI::errstr);   
            return;
        };
        $self->{_db}->do(q(SET SESSION CHARACTERISTICS AS TRANSACTION
                    ISOLATION LEVEL SERIALIZABLE));
        $self->{_db}->do(q{set DATESTYLE to 'DMY'});
        $self->log(LA_DEBUG, 'New connection to DB');
        $self->{_db}->commit;
        return $self->{_db};
    }
}

=head2 load

Read file and load data into memory

=cut

sub load {
    my ($self) = @_;
    if (!$self->db) { return 0 };

    my $sv = $self->get_global_value('schema_version') || 1;
    if ($sv < SCHEMA_VERSION) {
        $self->log(LA_CRIT,
            "Schema version %d found, %d is need, please update db using " .
            "`la-sql-upgrade' tool for `%s' base",
            $sv,
            SCHEMA_VERSION,
            $self->label,
        );
        # return;
    }

    1;
}

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

    my @groups = $self->search_objects('group', 'autoMemberFilter=*');

    foreach (@groups) {
        my $g = $self->get_object('group', $_) or next;
        $g->populate_dyn_group;
    }
}

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

    $self->_sync_dyn_group;

    if ($ENV{LA_NO_COMMIT}) {
        $self->log(LA_DEBUG, 'DB::COMMIT (ignore due to LA_NO_COMMIT)');
        return 1;
    } else {
        $self->log(LA_DEBUG, 'DB::COMMIT');
    }
    $self->{__cache} = undef;
    $self->db->commit;
}

sub _rollback {
    my ($self) = @_;
    if ($ENV{LA_NO_COMMIT}) {
        $self->log(LA_DEBUG, 'DB::ROLLBACK (ignore due to LA_NO_COMMIT)');
        return 1
    } else {
        $self->log(LA_DEBUG, 'DB::ROLLBACK');
    }
    $self->{__cache} = undef;
    $self->db->rollback;
}

sub list_supported_objects {
    my ($self, @otype) = @_;
    $self->SUPER::list_supported_objects(qw(site), @otype);
}

sub current_rev {
    my ($self) = @_;
    my $sth = $self->db->prepare_cached(
        q{select max(rev) from revisions}
    );
    $sth->execute;
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    return ($res->{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->attribute('user', 'exported')) {
        if (!$uobj->_get_c_field('exported')) {
            la_log(LA_ERR, "User $username found but currently unexported");
            return;
        }
    }

    $self->SUPER::authenticate_user($username, $passwd);
}

=head1 SPECIFICS FUNCTIONS

=head2 get_global_value ($varname)

Return global value set into base

=cut

sub get_global_value {
    my ($self, $varname) = @_;

    my $sth = $self->db->prepare_cached(q{
        select val from settings where varname = ?
        });
    $sth->execute($varname);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    $res->{val}
}

=head2 set_global_value ($varname, $value)

Set global value.

=cut

sub set_global_value {
    my ($self, $varname, $value) = @_;
    my $sth = $self->db->prepare(q{
        update settings set val = ? where varname = ?
        });
    $sth->execute($value, $varname) == 0 and do {
        my $sth2 = $self->db->prepare(q{
            insert into settings (val, varname) values (?,?)
            });
        $sth2->execute($value, $varname);
    };
}

=head2 generate_rsa_key ($password)

Return public and private peer rsa keys

=cut

sub generate_rsa_key {
    my ($self, $password) = @_;

    my $rsa = new Crypt::RSA ES => 'PKCS1v15';
    my ($public, $private) = $rsa->keygen (
        Identity  => 'LATMOS-Accounts',
        Size      => 2048,
        Password  => $password,
        Verbosity => 0,
    ) or die $rsa->errstr(); # TODO avoid die
    return ($public, $private);
}

=head2 private_key ($password)

Load and return private rsa key

=cut

sub private_key {
    my ($self, $password) = @_;
    my $base = $self;
    my $serialize = $base->get_global_value('rsa_private_key') or return;
    my $string = decode_base64($serialize);
    my $privkey = $string =~ /^SSH PRIVATE KEY FILE/
        ? Crypt::RSA::Key::Private::SSH->new
        : Crypt::RSA::Key::Private->new;
    $privkey = $privkey->deserialize(
        String => [ $string ],
        Password => $password
    );
    $privkey->reveal( Password => $password );
    $privkey;
}

=head2 get_rsa_password

Return hash with peer username => encryptedPassword

=cut

sub get_rsa_password {
    my ($self) = @_;
    my $base = $self;
    my $sth = $base->db->prepare(q{
        select "name", value from "user" join user_attributes_base
        on "user".ikey = user_attributes_base.okey
        where user_attributes_base.attr = 'encryptedPassword'
    });
    $sth->execute;
    my %users;
    while (my $res = $sth->fetchrow_hashref) {
        $users{$res->{name}} = $res->{value};
    }
    %users
}

=head2 store_rsa_key ($public, $private)

Store public and private RSA key info data base

=cut

sub store_rsa_key {
    my ($self, $public, $private) = @_;
    my $base = $self;
    $private->hide;
    $base->set_global_value('rsa_private_key',
        encode_base64($private->serialize));
    $base->set_global_value('rsa_public_key',
        $public->serialize);
    return;
}

=head2 find_next_expire_users ($expire)

Search user expiring in C<$expire> delay

=cut

sub find_next_expire_users {
    my ($self, $expire) = @_;

    my $sth= $self->db->prepare(q{
        select name from "user" where
            expire < now() + ?::interval
            and expire > now()
            and expire is not null
            } . ($self->{wexported} ? '' : 'and exported = true') . q{
            order by expire
        }
    );
    $sth->execute($expire || '1 month');
    my @users;
    while (my $res = $sth->fetchrow_hashref) {
        push(@users, $res->{name});
    }
    @users
}

=head2 find_expired_users ($expire)

Return list of user going to expires in C<$expire> delay

=cut

sub find_expired_users {
    my ($self, $expire) = @_;

    my $sth= $self->db->prepare(q{
        select name from "user" where
            expire < now() - ?::interval
            and expire is not null
        } . ($self->{wexported} ? '' : 'and exported = true') . q{
            order by expire
        }
    );
    $sth->execute($expire || '1 second');
    my @users;
    while (my $res = $sth->fetchrow_hashref) {
        push(@users, $res->{name});
    }
    @users
}

=head2 rename_nethost ($nethostname, $to, %config)

Facility function to rename computer to new name

=cut

sub rename_nethost {
    my ($self, $nethostname, $to, %config) = @_;
    {
        my $obj = $self->get_object('nethost', $nethostname) or do {
            $self->log(LA_ERR, 'Unable to rename non exisant host %s', $nethostname);
            return;
        };
        $obj->_delAttributeValue(cname => $to);
    }
    $self->rename_object('nethost', $nethostname, $to) or return;
    if ($config{'addcname'}) {
        my $obj = $self->get_object('nethost', $to);
        $obj->_addAttributeValue(cname => $nethostname);
    }
    return 1;
}

=head2 nethost_exchange_ip ($ip1, $ip2)

Exchange ip1 with ip2 in base

=cut

sub nethost_exchange_ip {
    my ($self, $ip1, $ip2) = @_;
    my ($obj1, $obj2);
    if (my ($host1) = $self->search_objects('nethost', "ip=$ip1")) {
        $obj1 = $self->get_object('nethost', $host1);
    } else {
        $self->log(LA_ERR, "Cannot find host having $ip1");
        return;
    }
    if (my ($host2) = $self->search_objects('nethost', "ip=$ip2")) {
        $obj2 = $self->get_object('nethost', $host2);
    } else {
        $self->log(LA_ERR, "Cannot find host having $ip2");
        return;
    }
    if ($obj1->id eq $obj2->id) {
        $self->log(LA_ERR, "Both ip belong to same host (%s)", $obj1->id);
        return;
    }

    $self->log(LA_NOTICE, "Exchanging IP between %s and %s", $obj1->id, $obj2->id);
    $obj1->delAttributeValue('ip', $ip1) or return;
    $obj2->delAttributeValue('ip', $ip2) or return;
    $obj1->addAttributeValue('ip', $ip2) or return;
    $obj2->addAttributeValue('ip', $ip1) or return;
    return 1;
}

=head1 ATTRIBUTES FUNCTIONS

=head2 register_attribute ($otype, $attribute, $comment)

Register a new attribute in base

=cut

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

=head2 is_registered_attribute ($otype, $attribute)

Return true is attribute already exists

=cut

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

=head2 get_attribute_comment ($otype, $attribute)

Return the comment associated to attribute

=cut

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

=head2 set_attribute_comment ($otype, $attribute, $comment)

Set comment to attribute

=cut

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

=head2 get_datarequest ($id)

Return user request C<$id>

=cut

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

    my $sth = $self->db->prepare(q{
        select name from request
        where id = ?
        });
    $sth->execute($id);
    if (my $res = $sth->fetchrow_hashref) {
        my $accreq = $self->get_object('accreq', $res->{name});
        return LATMOS::Accounts::Bases::Sql::DataRequest->new($accreq, $id);
    } else {
        return;
    }
}

=head2 list_requests

list user request currently waiting in base

=cut

sub list_requests {
    my ($self, $due) = @_;

    my $sth = $self->db->prepare(
        sprintf(
            q{
            select id from request
            where done is null
            %s
            order by apply
            },
            defined($due)
                ? 'and apply ' . ($due ? '<' : '>=') . ' now()'
                : ''
        )
    );
    $sth->execute;
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{id});
    }

    @ids
}

=head2 list_requests_by_submitter ($id)

list user request currently waiting in base ask by user C<$id>

=cut

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

    my $sth = $self->db->prepare(q{
        select id from request
        where done is null and "user" = ?
        order by apply
    });
    $sth->execute($id);
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{id});
    }

    @ids
}


=head2 list_request_by_object ($otype, $id, $req)

Return the list of pending request for a specific object

C<$req> is an optional forms name to limit search

=cut

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

    my $sth = $self->db->prepare(q{
        select * from request join
        accreq on request.name = accreq.name
        join accreq_attributes on accreq_attributes.okey = accreq.ikey
        where
        request.applied is NULL and
        accreq_attributes.attr = 'oType' and
        accreq_attributes.value = ?
        and request.object = ?
    } .
    ($req ? ' and request.name = ? ' : '')
    . q{
        order by apply
    });
    $sth->execute($otype, $id, ($req ? ($req) : ()));
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{id});
    }

    @ids
}

=head2 list_pending_requests

List user request to apply

=cut

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

    my $sth = $self->db->prepare(q{
        select id from request
        where done is null
            and apply < now()
        order by apply
    });
    $sth->execute;
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{id});
    }

    @ids
}

=head2 list_auto_pending_requests

List automatic request

=cut

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

    my $sth = $self->db->prepare(q{
        select id from request
        where done is null
            and apply < now()
            and automated = true
        order by apply
    });
    $sth->execute;
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{id});
    }

    @ids
}

sub ReportChange {
    my ($self, $otype, $name, $ref, $changetype, $message, @args) = @_;

    my $sthmodifiedby = $self->db->prepare(q{
        UPDATE objects set modifiedby = ? where ikey = ?
    });

    $sthmodifiedby->execute(
        $self->user || '@Console',
        $ref,
    );

    my $sth = $self->db->prepare(q{
        INSERT into objectslogs (ikey, irev, otype, name, changetype, username, message)
        VALUES (?,?,?,?,?,?,?)
        });

    $sth->execute(
        $ref,
        $self->current_rev,
        $otype,
        $name,
        $changetype,
        $self->user || '@Console',
        sprintf($message, @args),
    );
}

=head2 getobjectlogs($otype, $name)

Return logs for object type C<$otype> having C<$name>.

=cut 

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

    my $sth = $self->db->prepare(q{
        select ikey from objectslogs where
            otype = ? and
            name  = ?
        group by ikey
    });
    $sth->execute($otype, $name);
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{ikey});
    }
    @ids or return;

    my $sth2 = $self->db->prepare(sprintf(
        q{
            select * from objectslogs where ikey IN (%s)
            order by logdate asc
        },
        join(',', ('?') x scalar(@ids))
    ));

    $sth2->execute(@ids);
    my @logs;
    while (my $res = $sth2->fetchrow_hashref) {
        push(@logs, $res);
    }

    return @logs;
}

=head2 getlogs

Return logs for last year

=cut

sub getlogs {
    my ($self) = @_;
    my $sth2 = $self->db->prepare(
        q{
            select * from objectslogs 
            where logdate > now() - '1 year'::interval 
            order by logdate asc
        },
    );

    $sth2->execute();
    my @logs;
    while (my $res = $sth2->fetchrow_hashref) {
        push(@logs, $res);
    }

    return @logs;
}


1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

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