source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Heimdal/User.pm @ 2220

package LATMOS::Accounts::Bases::Heimdal::User;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases::Objects);
use LATMOS::Accounts::Log;

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

=head1 NAME

LATMOS::Ldap - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Ldap;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for LATMOS::Ldap, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head1 FUNCTIONS

=cut

sub _get_attr_schema {
    my ($class, $base, $info) = @_;
    $info ||= {};

    foreach (qw(
        uid
        modName
            )) {
        $info->{$_} = { ro => 1 };
    }
    $info->{userPassword} = { ro => 1, readable => 0 };
    foreach (qw(
        krb5ValidEnd
        krb5KDCFlags
        krb5MaxRenew
        krb5MaxLife
            )) {
        $info->{$_} = { };
    }

    return $info;
}    

sub _is_ignored_user {
    my ($base, $uid) = @_;

    $uid eq 'default' and return 1;
    grep { $uid eq $_ } split(/ *, */, $base->config('ignoredusers'))
        and return 1;

    return;
}

sub list {
    my ($class, $base) = @_;

    my $realm = $base->config('realm');
    my @uids;
    foreach ($base->heimdal->getPrincipals('*@' . $realm)) {
        /^([^@\/]+)\@\Q$realm\E$/ or next;
        my $uid = $1;
        _is_ignored_user($base, $uid) and next;
        push(@uids, $uid);
    }
    
    return @uids;

}

=head2 uid2principal ($uid, $base)

Convert UID to kerberos principal

=cut

sub uid2principal {
    my ($self, $uid, $base) = @_;
    my $ba = $base || $self->base;
    $uid ||= $self->id;
    return $uid . '@' . $ba->config('realm');
}


sub new {
    my ($class, $base, $uid) = @_;
    
    _is_ignored_user($base, $uid) and return;
    my $entry = $base->heimdal->getPrincipal($class->uid2principal($uid, $base));
    return if (!$entry);
    bless({ entry => $entry, _base => $base, _id => $uid }, $class);
}

sub _create {
    my ($class, $base, $id, %data) = @_;

    _is_ignored_user($base, $id) and do {
        $base->log('User %s is ignored by config, creation refused', $id);
        return;
    };
    my $principal = $base->heimdal->makePrincipal($class->uid2principal($id, $base));
    exists($data{krb5KDCFlags}) or $data{krb5KDCFlags} = 0;
    exists($data{krb5MaxRenew}) or $data{krb5MaxRenew} = 604800;
    exists($data{krb5MaxLife}) or $data{krb5MaxLife} = 86400;

    _setprincipal($principal, %data);
    my $pass = join('', map { ('a'..'z')[rand 26] } (0..10));
    return $base->heimdal->createPrincipal($principal, $pass);

    return 1;
}

sub _delete {
    my ($class, $base, $uid) = @_;
    _is_ignored_user($base, $uid) and return;
    my $obj = $class->new($base, $uid) or return;

    my $code = $base->heimdal->deletePrincipal($class->uid2principal($uid, $base));

    if (!$code) {
        $base->log(LA_ERR, "Cannot delete object %s", $uid);
        return;
    } else {
        $base->log(LA_INFO, "Object (%s) %s delete", $class->type, $uid);
        return 1
    }
}

sub _rename {
    my ($class, $base, $uid, $newuid) = @_;
    my $obj = $class->new($base, $uid) or return;

    my $mesg = $base->ldap->moddn( $obj->{entry},
        newrdn => 'cn=' .  escape_filter_value($newuid),
        deleteoldrdn => 1,
    );

    if ($mesg->code) {
        $base->log(LA_ERR, "Cannot rename object %s: %s", $uid, $mesg->error);
        return;
    } else {
        return 1;
    }
}

sub get_field {
    my ($self, $field) = @_;

    for ($field) {
        /uid/ and return $self->id;
        /modName/ and return $self->{entry}->getModName();
        /krb5ValidEnd/ and do {
            # (2^31) - 1 means no expiration
            my $val = $self->{entry}->getPrincExpireTime();
            return $val == 2_147_483_647 ? undef : $val;
        };
        /krb5KDCFlags/ and return $self->{entry}->getAttributes();
        /krb5MaxRenew/ and return $self->{entry}->getMaxRenewableLife();
        /krb5MaxLife/ and return $self->{entry}->getMaxLife();
        /userPassword/ and return '';
    }

    return;
}

sub _setprincipal {
    my ($principal, %fields) = @_;
    for (keys %fields) {
        # It's seems krb5ValidEnd cannot be unset using perl API
        # so we're setting the expiration to max time (2^31 - 1)
        /krb5ValidEnd/ and $principal->setPrincExpireTime($fields{$_} || 2_147_483_647);
        /krb5KDCFlags/ and $principal->setAttributes($fields{$_} || 0);
        /krb5MaxRenew/ and $principal->setMaxRenewableLife($fields{$_} || 0);
        /krb5MaxLife/ and $principal->setMaxLife($fields{$_} || 0);
    }
}


sub set_fields {
    my ($self, %fields) = @_;

    _setprincipal($self->{entry}, %fields);

    return $self->base->heimdal->modifyPrincipal($self->{entry});
}

sub _set_password {
    my ($self, $clear_pass) = @_;

    $self->base->heimdal->changePassword(
        $self->uid2principal(),
        $clear_pass
    );
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.frE<gt>

=head1 COPYRIGHT AND LICENSE

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