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

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 MIME::Base64;

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

my $SCHEMA_VERSION = 5;

=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 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 _commit {
    my ($self) = @_;
    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});
} 

=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      => 768,
        Password  => $password,
        Verbosity => 0,
        KF=>'SSH',
    ) 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 $privkey = Crypt::RSA::Key::Private::SSH->new;
    $privkey->deserialize(String => [ decode_base64($serialize) ],
        Passphrase => $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;
    $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);
        my @cname = grep { $_ && $_ ne $to}
        $obj->get_attributes('cname');
        $obj->set_c_fields(cname => [ @cname ]) or return;
    }
    $self->rename_object('nethost', $nethostname, $to) or return;
    if ($config{'addcname'}) {
        my $obj = $self->get_object('nethost', $to);
        my @cname = grep { $_ } $obj->get_attributes('cname');
        $obj->set_c_fields(cname => [ @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->la_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->la_log(LA_ERR, "Cannot find host having $ip2");
        return;
    }
    if ($obj1->id eq $obj2->id) {
        $self->la_log(LA_ERR, "Both ip belong to same host (%s)", $obj1->id);
        return;
    }

    my @ip1 = grep { $_ && $_ ne $ip1 } $obj1->get_attributes('ip');
    $obj1->set_c_fields(ip => [ @ip1 ]);
    my @ip2 = grep { $_ && $_ ne $ip2 } $obj2->get_attributes('ip');
    $obj2->set_c_fields(ip => [ @ip2, $ip1 ]) or return;
    $obj1->set_c_fields(ip => [ @ip1, $ip2 ]) 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);
}

sub _check_user_manager {
    $_[0]->_handle_by_unexported('user', 'manager', 'active');
}

sub _check_group_manager {
    $_[0]->_handle_by_unexported('group', 'managedBy');
}

sub _check_nethost_owner {
    $_[0]->_handle_by_unexported('nethost', 'owner', 'active');
}

sub _handle_by_unexported {
    my ($self, $otype, $refattr, $chkattr) = @_;

    my $ptrotype = $self->attribute($otype, $refattr)->reference();

    my %unhandle;
    foreach my $objname ($self->search_objects($otype, 'active=1', 'exported=1', "$refattr=*")) {
        my $obj = $self->get_object($otype, $objname) or next;
        my $val = $obj->get_attributes($refattr) or next;
        if (my $refobj = $self->get_object($ptrotype, $val)) {
            if (!$refobj->get_attributes($chkattr || 'exported')) {
                $unhandle{$objname} = $val;
            }
        } else {
            $unhandle{$objname} = $val;
        }
    }
    %unhandle;
}

=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)

Return the list of pending request for a specific object

=cut

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

    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 = ?
        order by apply
    });
    $sth->execute($otype, $id);
    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
}

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