source: LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Heimdal.pm @ 861

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

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use LATMOS::Accounts::Log;
use Heimdal::Kadm5;

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

=head1 NAME

LATMOS::Heimdal - Latmos Accounts support for kerberos/heimdal

=head1 SYNOPSIS

  use LATMOS::Heimdal;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for LATMOS::Heimdal, 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

=head2 new(%options)

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

options:

=over 4

=item domain

The DNS domain where information about kerberos server can be found, eg the
REALM in the B<TXT> record B<kerberos> and the admin server from B<SRV> record
B<_kerberos-adm._tcp>.

This paramater can be omited if both B<realm> and B<server> are set.

=item realm

The kerberos realm to connect to. Can be omit if B<domain> is given and this DNS
domain contains kerberos record.

See B<domain> parameter.

=item server

If set, try to connect to this server, if not set, a dns query is performed
to find kerberos admin server, first responding is used.

See B<domain> parameter.

=item ignoredusers

A coma separated list of user (login) to not modify or delete in the database.

The user named 'default' is automatically ignored.

=back

=cut

sub new {
    my ($class, %options) = @_;
    
    my $self = {
        _param => { %options },
    };

    bless($self, $class);
}

sub param {
    my ($self, $var) = @_;
    return $self->{_param}{$var}
}

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

    # If already loaded, just say ok !
    $self->{_heimdal} and return 1;

    if (!$self->param('realm')) {
        if ($self->param('domain')) {
            $self->{_param}{realm} = $self->_domain2realm or do {
                $self->log(LA_ERR,
                    'Cannot find kerberos TXT record for domain `%s\'',
                    $self->param('domain'),
                );
                return;
            };
            $self->log(LA_DEBUG, 'kerberos REALM is %s', $self->param('realm'));
        } else {
            # No way to find realm
            return;
        }
    }
    my @servers = $self->param('server')
        ? ($self->param('server'))
        : $self->param('domain')
            ? $self->_domain2server
            : ();

    if (!@servers) {
        # no servers found
    }

    foreach my $server (@servers) {
        my $heimdal = Heimdal::Kadm5::Client->new(
            # RaiseErrors => 1,
            Server => $server,
            # Port   => '8899',
            # Required:
            Principal => $self->param('login'),
            Realm  => $self->param('realm'),
            # --- Either ---
            Password => $self->param('password'),
            # --- Or ---
            # Keytab => $self->param('keytab'),
        );

        if($heimdal) {
            $self->log(LA_DEBUG, "Connected to heidmal server %s",
                $server);
            $self->{_heimdal} = $heimdal;
            last;
        } else {
            $self->log(LA_ERR, "Cannot connect to %s", $server);
        }
    }

    if (!$self->{_heimdal}) {
        $self->log(LA_ERR, "Cannot connect to any kerberos server");
        return;
    }

    return 1;
}

sub _domain2server {
    my ($self) = @_;
    require Net::DNS;
    my @servers;

    my $resolver = Net::DNS::Resolver->new;
    my $query = $resolver->query("_kerberos-adm._tcp." . $self->param('domain'),
        "SRV") or return;
    foreach my $rr (
        sort { $a->priority <=> $b->priority || $a->weight <=> $b->weight }
        grep { $_->type eq 'SRV' } $query->answer) {
        push(@servers, $rr->target); # $rr->port)); don't use port
    }

    @servers
}
sub _domain2realm {
    my ($self) = @_;
    require Net::DNS;

    my $resolver = Net::DNS::Resolver->new;
    my $query = $resolver->query(
        "_kerberos." . $self->param('domain'),
        "TXT") or return;
    foreach my $rr ($query->answer) {
        $rr->type eq 'TXT' and return $rr->txtdata;
    }

    return;
}

sub heimdal {
    return $_[0]->{_heimdal};
}

package Heimdal::Kadm5; 
sub DESTROY { }

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