debian-edu-config 1.702 / usr / share / perl5 / Debian / Edu.pm

package Debian::Edu;

use strict;

use Net::DNS;
use Net::LDAP;
use Term::ReadKey;

use vars qw(@ISA @EXPORT @EXPORT_OK);

require DynaLoader;
require Exporter;
@ISA = qw(Exporter DynaLoader);

@EXPORT = qw(find_ldap_server find_ldap_base
             find_kerberos_server find_kerberos_realm);
@EXPORT_OK= qw(prompt4password);

# Convert hostname or IP address to the canonical DNS name, to make
# sure DNS CNAMEs etc can be compared.
sub canonize_hostname {
    my $hostname = shift;
    my ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($hostname);
    return scalar gethostbyaddr($addrs[0], $addrtype);
}

# Take a list of host names and return the list of pingable hosts
# among these.
sub pingable_hosts {
    return undef unless @_;
    my $servers = join(" ", @_);
    my $pingservers = `/usr/bin/fping -a $servers 2> /dev/null`;
    return split(/\s+/, $pingservers);
}

sub parse_ldap_conf {
    my $cfg = "/etc/ldap/ldap.conf";
    if ( -r $cfg ) {
        if (open(my $fh, "<", $cfg)) {
            my $base;
            my $host;
            while (<$fh>) {
                chomp;
                $base = $1 if (m/^base\s+(\S+.*)\S*$/i);
                $host = $1 if (m/^host\s+(\S+.*)\S*$/i);
                $host = $1 if (m%^uri\s+ldap://([^/]+)%i);
            }
            return ($host, $base);
        }
    }
}

sub find_ldap_server {
    my ($dnsdomain) = @_;
    # Use the global settings from ldap.conf if they exist, to allow
    # the settings to be changed from a central point.
    my ($server, $base) = parse_ldap_conf();
    return $server if $server;

    # Prefer DNS entry named ldap
    if (pingable_hosts("ldap")) {
        return canonize_hostname("ldap");
    }

    my $res = Net::DNS::Resolver ->new;
    $res->retrans(2); # default 5
    $res->retry(2); # default 4
    $res->tcp_timeout(5); # default 120
    $res->udp_timeout(5); # default 120
    my @nameservers = map { canonize_hostname($_) } $res->nameservers;
    my $srv_query = $res->search("_ldap._tcp.$dnsdomain", "SRV");
    if (!defined($srv_query)) {
        return undef;
    }
    my @ldapservers;
    for my $answer ($srv_query->answer) {
        my $servername = canonize_hostname($answer->target);
        push(@ldapservers, $servername);
    }
    # Prefer one of the current DNS servers used if it is in the list
    # of LDAP servers, to ensure any DNS updates done using LDAP take
    # effect imediately.
    for my $nameserver (pingable_hosts(@nameservers)) {
        for my $ldapserver (@ldapservers) {
            if ($nameserver eq $ldapserver) {
                return $nameserver;
            }
        }
    }
    return (pingable_hosts(@ldapservers))[0];
}

sub find_ldap_base {
    my $ldapserver = shift;

    # Use the global settings from ldap.conf if they exist, to allow
    # the settings to be changed from a central point.
    my ($server, $base) = parse_ldap_conf();
    return $base if ($server eq $ldapserver && $base);

    my $ldapref = Net::LDAP->new($ldapserver)
        or die "Can't bind to ldap server $ldapserver: $!\n";
    $ldapref->bind();
    my $dse = $ldapref->root_dse();
    my @contexts = $dse->get_value('namingContexts');

    $base = undef;
    if (1 > scalar @contexts) {
        return undef;
    } elsif (1 < scalar @contexts) {
        # More than one context, try to look for defaultNamingContext,
        # which is present on Active Directory.
        if (my $defaultcontext = $dse->get_value('defaultNamingContext')) {
            $base = $defaultcontext;
        } else {
            # Pick the first one with posixAccount or posixGroup
            # objects in it.
            for my $context (@contexts) {
                my $mesg = $ldapref->search(
                    base   => $context,
                    filter => '(|(objectClass=posixAccount)(objectClass=posixGroup))',
                    sizelimit => 1,
                    );
                if (0 < $mesg->count()) {
                    $base = $context;
                    last;
                }
            }
        }
    } else {
        $base = $contexts[0];
    }

    if (!$ldapref->unbind) {
        print "error: unbinding from LDAP server\n";
    }

    return $base;
}

sub find_kerberos_realm {
    my $dnsdomain = shift;

    my $res = Net::DNS::Resolver->new;
    $res->retrans(2); # default 5
    $res->retry(2); # default 4
    $res->tcp_timeout(5); # default 120
    $res->udp_timeout(5); # default 120
    my $srv_query = $res->search("_kerberos.$dnsdomain", "TXT");
    if (defined($srv_query)) {
        for my $answer ($srv_query->answer) {
            return $answer->rdata();
        }
    }
    return uc($dnsdomain);
}

sub find_kerberos_server {
    my ($dnsdomain) = @_;
    # Prefer DNS entry named kerberos
    if (pingable_hosts("kerberos")) {
        return canonize_hostname("kerberos");
    }

    my $res = Net::DNS::Resolver->new;
    $res->retrans(2); # default 5
    $res->retry(2); # default 4
    $res->tcp_timeout(5); # default 120
    $res->udp_timeout(5); # default 120
    my @nameservers = map { canonize_hostname($_) } $res->nameservers;
    my $srv_query = $res->search("_kerberos._tcp.$dnsdomain", "SRV");
    if (!defined($srv_query)) {
        return undef;
    }
    my @krbservers;
    for my $answer ($srv_query->answer) {
        my $servername = canonize_hostname($answer->target);
        push(@krbservers, $servername);
    }
    # Prefer one of the current DNS servers used if it is in the list
    # of Kerberos servers, to ensure any LDAP and Kerberos updates
    # done take effect imediately.
    for my $nameserver (pingable_hosts(@nameservers)) {
        for my $krbserver (@krbservers) {
            if ($nameserver eq $krbserver) {
                return $nameserver;
            }
        }
    }
    return (pingable_hosts(@krbservers))[0];
}

# prompt function copied from http://www.perlmonks.org/?node_id=553981
sub prompt4password {
    my ($prompt, %args) = @_;
    local $| = 1;
    my $phrase = '';
    print $prompt;
    ReadMode 'cbreak';
    while (1) {
        my $c = ReadKey ~0/2-1; #windows workaround http://rt.cpan.org/Public/Bug/Display.html?id=27944
        if ($c =~ /[\r\n]/) {
            print "\n";
            last;
        }
        elsif ($c eq "\b" || ord $c == 127) {
            next unless length $phrase;
            chop $phrase;
            next if !defined $args{-echo};
            print map $_ x length $args{-echo}, "\b", " ", "\b";
        }
        elsif (ord $c) {
            $phrase .= $c;
            print $args{-echo} if defined $args{-echo};
        }
    }
    ReadMode 'restore';
    $phrase;
}

# Allow functins in module to over replaced by other packages and
# local modifications when needed.
eval "require Debian::Edu_Overlay";
if ($@ && $@ !~ qr{^Can't locate Debian/Edu_Overlay.pm}) {
    die $@;
};

eval "require Debian::Edu_Vendor";
if ($@ && $@ !~ qr{^Can't locate Debian/Edu_Vendor.pm}) {
    die $@;
};

eval "require Debian::Edu_Local";
if ($@ && $@ !~ qr{^Can't locate Debian/Edu_Local.pm}) {
    die $@;
};

1;