#!/usr/bin/perl
# LDAP authentication pool
# Rowan Littell, 2007
#
# HOW TO USE THIS SCRIPT:
#  * Edit the @LDAP_SERVERS, $BIND_DN, $BIND_PW, and $SEARCH_BASE variables
#    to reflect your LDAP servers
#  * Edit the MAIN section to collect username and password attempts as
#    needed by your application.  Alternately, turn MAIN into a new
#    subroutine and embed this in some other perl script.
#
# The rest of the script probably won't need to be changed unless you
# use a different LDAP schema, object classes, or authentication
# mechanism (this assumes authenticated bind).  See the comments in the
# routines below if you think any of this may apply.
#
# WHAT THIS SCRIPT DOES:
#
#  This script maintains a pool of active LDAP connections, bound as a
#  semi-privileged search user (a user that is usually allowed to see
#  all other users but not modify their atttributes nor see sensitive
#  attributes such as password hashes).  When given a username and
#  password, it first checks to see whether there are any active
#  connections, restarting inactive ones as necessary if they have
#  been inactive for a sufficiently long period of time.  Then it
#  searches all currently active connections until it gets a
#  definitive answer (either the user exists or doesn't).  In the
#  process, if any of the connections were tried and failed, those
#  connections are marked as inactive.  If the user exists, then the
#  server that provided the answer is used to attempt an authenticated
#  bind with the supplied password and the discovered DN.  If the bind
#  is successful, then successful authentication is returned.
#
#  When searching, the algorithm sorts the LDAP connection pool by
#  order of connection speed (as determined by calls to gettimeofday
#  before and after Net::LDAP->new).  It asks the fastest server
#  first, if it is active.  When an authenticated bind is attempted,
#  the connection speed from that attempt is stored as that server's
#  connection speed for the next search.  This lets the algorithm
#  settle on the perceived "fastest" LDAP server but gracefully move
#  to a different one as necessary.
#
#  Drawbacks:
#    * Due to socket complexities, it seems that Net::LDAP does not
#      support asynchronous queries.  This means that multiple servers
#      cannot be queried simultaneously.  Instead, searches for the user
#      DN are performed sequentially from the pool of active connections.
#    * There is no easy way to specify a socket timeout for a Net::LDAP
#      object, so when an LDAP server drops off the net and the connections
#      timeout, this will stall the script.
#    * The way to get around these difficulties is probably either to
#      redo the socket connection for the Net::LDAP object, use threads,
#      or use separate processes.  Any of these introduce other complexities.
#
# Data Structure:
#   %objects, returned from connect_ldap(), is a hash.  Each hash entry is
#   the address of an LDAP server and references a hash with the following
#   structure:
#     $objects{$address}->{'ldap'}     - a Net::LDAP object
#     $objects{$address}->{'time'}     - the connection speed
#     $objects{$address}->{'active'}   - whether the connection is alive
#     $objects{$address}->{'deadtime'} - time at which the connection failed
#     $objects{$address}->{'dn'}       - bind DN
#     $objects{$address}->{'password'} - bind password
#     $objects{$address}->{'searches'} - number of searches performed
#     $objects{$address}->{'bind'}     - whether connection is bound
#
##############################################################################

###########
# necessary modules
use strict;
use Net::LDAP;
use Sys::Syslog qw (:DEFAULT setlogsock);
use Time::HiRes qw (gettimeofday);

###########
# EDIT THESE
my @LDAP_SERVERS = (
		    "ldap1.example.org",
		    "ldap2.example.org",
		    "ldap3.example.org"
		    );
my $BIND_DN = "uid=ldap-search,cn=users,dc=example,dc=org";
my $BIND_PW = "soopersekrit";
my $SEARCH_BASE = "dc=example,dc=org";

#################################################################
# MAIN is the only function you want to change.  This is the part
# of the program that collects the username and password for the
# authentication attempt and sends it to the LDAP pool.
#
# This example simply collects a username and password on STDIN
# separated by a space and attempts authentication.
MAIN:
{
    # set autoflush
    $| = 1;

    # Open a syslog connection
    setlogsock('unix');
    openlog ('ldap-pool-auth', 'pid', 'authpriv');

    # Create the LDAP search pool.  This connects to the LDAP servers
    # specified in the array and then binds as the semi-privileged search
    # entity.
    my %objects = connect_ldap ('2', @LDAP_SERVERS);
    bind_ldap ($BIND_DN, $BIND_PW, %objects);

    while (<>) {
    	chomp;
	my ($username, $password) = (split /\s+/, $_, 2);

	if ($username ne "" and $password ne "") {
	    # Each connection is searched, if active, until the username
	    # is found, and then a new connection to that LDAP server is
	    # opened and authenticated bind is attempted.
	    my $auth = auth_ldap ($username, $password, $SEARCH_BASE, %objects);
	    if ($auth) {
		print "Ok: $username\n";
	    } else {
		print "Error: $username\n";
	    }
	}
    }

    closelog();
}

###########################################################################
# %% connect_ldap
# %% ARGUMENTS:
# %%  timeout: integer number of seconds for connection timeout
# %%  servers: array of server host names or IP addresses to connect to
# %% RETURNS:
# %%  objects: hash of connected LDAP server objects that can be used in
# %%           other functions
# %% EFFECTS:
# %%  Connects to each of the given LDAP servers and stores the Net::LDAP
# %%  object in the hash, along with other information about the connection
# %%  (the connect speed and whether the connection is alive).
#
sub connect_ldap ($@) {
    my ($timeout, @servers) = @_;
    my (%objects);
    my $count = 0;

    foreach my $address (@servers) {
	# record start time for choosing the fastest responding server
	my $stime = gettimeofday;

	my $ldap = Net::LDAP->new ($address,
				   timeout => $timeout,
				   version => 3,
				   async => 0
				   );

	# end time - start time gives us connect time.
	my $etime = gettimeofday;
	my $time = $etime - $stime;

	# if we got a valid object, stuff it into the hash,
	# mark it as active and record the connect time
	if (defined $ldap) {
	    $objects{$address}->{'ldap'} = $ldap;
	    $objects{$address}->{'time'} = $time;
	    $objects{$address}->{'active'} = 1;
	    $count++;
	    syslog ('notice', "connect_ldap: OK $address $time");
	} else {
	    # if the connect failed, mark it as inactive, set the connect
	    # speed time to something ridiculous, and set the time at which
	    # it became inactive to now.
	    $objects{$address}->{'time'} = 68040;
	    $objects{$address}->{'active'} = 0;
	    $objects{$address}->{'deadtime'} = time();
	    syslog ('warning', "connect_ldap: FAIL $address $time");
	}
    }

    # log the number of servers connected
    syslog ('notice', "connect_ldap: $count connected");

    # return the LDAP objects and their associated data
    return (%objects);
}

###########################################################################
# %% bind_ldap
# %% ARGUMENTS:
# %%  bind_dn: DN with which to bind to the LDAP server
# %%  bind_pw: password to use for binding to the LDAP server
# %%  servers: hash of connected server objects
# %% EFFECTS:
# %%  Performs an LDAP bind on the connected servers using the DN and
# %%  password supplied.  Sets the 'bind' attribute on the hash to 1 if
# %%  the bind was successful.
#
sub bind_ldap ($$%) {
    my ($bind_dn, $bind_pw, %servers) = @_;

    foreach my $address (keys %servers) {
	# set DN and password information for each server in case
	# this connection ever fails and we want to reconnect.
	$servers{$address}->{'dn'} = $bind_dn;
	$servers{$address}->{'password'} = $bind_pw;
	$servers{$address}->{'searches'} = 0;

	# Initially set the bind attribute to false.
	$servers{$address}->{'bind'} = 0;

	# go on to the next server if this one is inactive (mainly if
	# the connect failed).
	next if (!$servers{$address}->{'active'});

	# perform the bind
	my $rv = $servers{$address}->{'ldap'}->bind
	    ($bind_dn, password => $bind_pw);

	# if there was an error, disconnect and set the server to inactive
	if ($rv->code) {
	    my $err = $rv->error;
	    syslog ('warning', "bind_ldap: FAIL $address $bind_dn [$err]");
	    $servers{$address}->{'active'} = 0;
	    $servers{$address}->{'ldap'}->disconnect;
	    $servers{$address}->{'bind'} = 0;
	    $servers{$address}->{'deadtime'} = time();
	} else {
	    # log the connection and set bind to true
	    syslog ('notice', "bind_ldap: OK $address $bind_dn");
	    $servers{$address}->{'bind'} = 1;
	}
    }
}

###########################################################################
# %% disconnect_ldap
# %% ARGUMENTS:
# %%  servers: hash of connected server objects
# %% EFFECTS:
# %%  Unbinds and disconnects each server.
#
sub disconnect_ldap (%) {
    my (%servers) = @_;

    # unbind and disconnect from each server
    foreach my $address (keys %servers) {
	$servers{$address}->{'ldap'}->unbind;
	$servers{$address}->{'ldap'}->disconnect;
	syslog ('notice', "disconnect_ldap: OK $address");
    }
}

###########################################################################
# %% reconnect_ldap
# %% ARGUMENTS:
# %%  address: address of server to reconnect to
# %%  servers: hash of server objects
# %% RETURNS:
# %%  0: fail
# %%  1: success
# %% EFFECTS:
# %%  Attempts a reconnect and rebind for the server if it is in the
# %%  inactive pool.  Sets associated hash data accordingly.
#
sub reconnect_ldap ($%) {
    my ($address, %servers) = @_;
    my $reconnected = 0;

    if (!$servers{$address}->{'active'}) {
	# record start time
	my $stime = gettimeofday;

	# make new connection
	my $ldap = Net::LDAP->new ($address,
				   timeout => 1,
				   version => 3,
				   async => 0
				   );

	# record end time
	my $etime = gettimeofday;
	my $time = $etime - $stime;

	# as above in connect_ldap
	if (defined $ldap) {
	    $servers{$address}->{'ldap'} = $ldap;
	    $servers{$address}->{'time'} = $time;
	    $servers{$address}->{'active'} = 1;
	    $servers{$address}->{'searches'} = 0;
	    syslog ('notice', "reconnect_ldap(connect): OK $address $time");

	    # bind the new connection, as above in bind_ldap
	    my $bind_dn = $servers{$address}->{'dn'};
	    my $rv = $servers{$address}->{'ldap'}->bind (
		     $servers{$address}->{'dn'},
		     password => $servers{$address}->{'password'});
	    if ($rv->code) {
		my $err = $rv->error;
		syslog ('warning', "reconnect_ldap(bind): FAIL $address $bind_dn [$err]");
		$servers{$address}->{'ldap'}->disconnect;
		$servers{$address}->{'bind'} = 0;
		$servers{$address}->{'deadtime'} = time();
	    } else {
		syslog ('notice', "reconnect_ldap(bind): OK $address $bind_dn");
		$servers{$address}->{'bind'} = 1;
		$reconnected = 1;
	    }
	} else {
	    $servers{$address}->{'time'} = 68040;
	    $servers{$address}->{'active'} = 0;
	    $servers{$address}->{'deadtime'} = time();
	    syslog ('warning', "reconnect_ldap(connect): FAIL $address $time");
	}
    } else {
	syslog ('notice', "reconnect_ldap: ERR $address [not inactive]");
    }

    return ($reconnected);
}

###########################################################################
# %% verify_active
# %% ARGUMENTS:
# %%  min_servers: minimum number of servers that must be active
# %%  deadtime: number of seconds that a server must be dead before reconnect
# %%  servers: hash of the server objects
# %% RETURNS:
# %%  number of active servers
# %% EFFECTS:
# %%  Verifies that the requested number of servers are connected
# %%  and connects enough to fulfill the minimum requirement.
#
sub verify_active ($$%) {
    my ($min_servers, $deadtime, %servers) = @_;
    my $curtime = time();
    my $connected = 0;
    my @active = ();

    # sort the servers based on their most recent connect speed
    my @addresses = sort {
	$servers{$a}->{'time'} <=> $servers{$b}->{'time'}
    } keys %servers;


    # go through the list.  if it's active, record it
    # if it's not active and deadtime has timed out and we need another server
    # then try to reconnect.
    foreach my $address (@addresses) {
	if ($servers{$address}->{'active'}) {
	    if ($servers{$address}->{'ldap'}->{'net_ldap_socket'}->connected()) {
		push @active, $address;
		$connected++;
	    } else {
		syslog ('warning', "verify_active: INFO $address disconnected [failed IO::Socket connected test]");
		$servers{$address}->{'active'} = 0;
		$servers{$address}->{'deadtime'} = time();
	    }
	} elsif ($connected < $min_servers &&
	    $servers{$address}->{'deadtime'} != 0 &&
	    $curtime - $servers{$address}->{'deadtime'} > $deadtime) {

	    if (reconnect_ldap ($address, %servers)) {
		push @active, $address;
		$connected++;
	    }
	}
    }

    syslog ('notice', "verify_active: INFO $connected active [" . join (",", @active) . "]");
    return ($connected);
}


###########################################################################
# %% auth_ldap
# %% ARGUMENTS:
# %%  username: username to authenticate
# %%  password: password to attempt authentication with
# %%  base_dn: the search base in the LDAP tree
# %%  servers: hash of server objects
# %% RETURNS:
# %%  0: fail
# %%  1: success
# %% EFFECTS:
# %%  Searches for the DN of the username and then attempts to bind with
# %%  that DN and the supplied password.  Also cycles through the server
# %%  list and attempts to reconnect any inactive server if it has been
# %%  inactive for more than 10 minutes.
#
sub auth_ldap ($$$%) {
    my ($username, $password, $base_dn, %servers) = @_;
    my ($user_dn, $active_server);
    my $auth = 0;
    my $done = 0;
    my $curtime = time();

    # sort the servers based on their most recent connect speed
    my @addresses = sort {
	$servers{$a}->{'time'} <=> $servers{$b}->{'time'}
    } keys %servers;

    # request that all servers are active and require at least 1
    my $active = verify_active ($#addresses+1, 600, %servers);
    if (!$active) {
	syslog ('warning', "auth_ldap: ERR inactive [no servers active at 600 seconds]");
	# try again with a smaller deadtime and only 1 server
	$active = verify_active (1, 15, %servers);
	if (!$active) {
	    syslog ('warning', "auth_ldap: ERR inactive [no servers active at 15 seconds]");
	    return 0;
	}
    }

    # search the servers for the user's DN, stopping at the first
    # response, either positive or negative.  If a server's response is
    # an error, mark it as inactive and continue to the next server.

    for (my $i = 0; $i <= $#addresses && !$done; $i++) {
	my $address = $addresses[$i];

	# continute to the next server if this one is inactive
	next if (!$servers{$address}->{'active'});

	# perform the search
	# NOTE: if your LDAP server uses a different schema, you may
	# need to modify the filter in this search.
	syslog ('notice', "auth_ldap: INFO $address " . $servers{$address}->{'searches'} . " searches");
	my $stime = gettimeofday();
	my $search = $servers{$address}->{'ldap'}->search (
			 base => $base_dn,
			 filter => "(uid=$username)",
			 attrs => ['uid'],
			 timelimit => 2
	);
	my $etime = gettimeofday();
	my $search_time = $etime - $stime;
	$servers{$address}->{'searches'}++;
	syslog ('notice', "auth_ldap: INFO $address search time $search_time");

	# If the search returned an error, mark the server as inactive
	# and continue to the next server (we assume that the error
	# was caused by non-response from server or connection failure
	# or similar).

	if ($search->code) {
	    my $err = $search->error;
	    syslog ('warning', "auth_ldap: ERR $address $username [$err]");
	    $servers{$address}->{'active'} = 0;
	    $servers{$address}->{'deadtime'} = time();
	} else {
	    if ($search->count == 1) {
		my $entry = $search->entry(0);
		$user_dn = $entry->dn;
		syslog ('notice', "auth_ldap: OK $address $username [DN found: $user_dn]");
		# record which server responded so we can do the bind to
		# it in the next step.
		$active_server = $address;
	    } else {
		# either count was 0 or > 1, search failed
		syslog ('warning', "auth_ldap: FAIL $address $username [DN not found]");
	    }

	    # server responded definitively, one way or another
	    $done = 1;
	}
    }

    # if we found the DN and the password is not null, try the bind
    if ($done && $user_dn ne '' && $password ne '') {

	# create a mini-hash for just this server, set a quick timeout
	my %s = connect_ldap('1', $active_server);

	# try the bind with the supplied password
	if ($s{$active_server}->{'active'}) {
	    bind_ldap ($user_dn, $password, %s);
	    if ($s{$active_server}->{'bind'}) {
		syslog ('notice', "auth_ldap: OK $active_server $username [bind successful for $user_dn]");

		# update the active server's connection speed with
		# the speed we got from this attempt.
		$servers{$active_server}->{'time'} = $s{$active_server}->{'time'};
		# set successful authentication
		$auth = 1;
	    } else {
		syslog ('warning', "auth_ldap: FAIL $active_server $username [bind failed for $user_dn]");

		# set authentication failure
		$auth = 0;
	    }
	} else {
	    syslog ('warning', "auth_ldap: ERR $active_server $username [failed to connect for user bind]");
	}

	# disconnect
	disconnect_ldap (%s);
    }

    # return success or failure
    return ($auth);
}