External Authentication

Adaptor Example

#!/exlibris/metalib/m3_1/product/bin/perl -w

#############################################################
#
#  Perl script: hook.cgi (One Search Log On)
#      Version: 1.2
#
#  2005, Michael Doran, doran@uta.edu
#  University of Texas at Arlington
#
#  For MetaLib external authentication via PDS using
#  the remote login "Hook" 
#
#  Requires these Perl modules:
#	Net::LDAP
#	Date::Calc
#
#  See configuration in
#	/exlibris/metalib/m3_1/pds/conf_table/tab_service.uta
#
#  Note: turn debug on/off in 
#	/exlibris/metalib/m3_1/pds/program/call_httpsd_LWP
#  ...and look for output in 
#	/exlibris/metalib/m3_1/log/
#

use strict;

# Set expiry date for patron record in MetaLib
my $bor_expiry_date = &CalcExpiryDate;
sub CalcExpiryDate {
    use Date::Calc qw(Add_Delta_Days check_date);
    my ($sec, $min, $hour, $mday, $mon, $year,
        $wday, $yday, $isdat) = localtime(time);
       $mon         += 1;
       $year        += 1900;
    my $date_offset = "365";
    ($year, $mon, $mday)
        = Add_Delta_Days($year, $mon, $mday, $date_offset);
       $mon           = sprintf("%02d", $mon);
       $mday          = sprintf("%02d", $mday);
    my $bor_expiry_date = $year . $mon . $mday;
    if ($bor_expiry_date =~ /\d{8}/) {
        return($bor_expiry_date);
    } else {
        return('');
    }
}



my $metalib_base_URL = "https://onesearch.uta.edu/pds";

#############################################################
#
#  LDAP server variables
#
#  University of Texas at Arlington LDAP servers:
#	ldap.cedar.uta.edu  -  LDAP server load balancer
#         pi.cedar.uta.edu  -  individual LDAP server 
#         xi.cedar.uta.edu  -  individual LDAP server 
#
#  Connection approaches:
#  OK     : Connect to an individual LDAP server.
#  Better : Connect to a LDAP server load balancer (if your campus has
#           one).  This will distribute the load among available LDAP
#           servers and authentication will succeed even if one of the
#           individual LDAP servers is unavailable.
#  Best   : Per the Net::LDAP documentation, create a list (array) of
#           LDAP servers, putting the LDAP load balancing host first,
#           followed by the individual LDAP servers.  Reference the
#           array, and connect to the array reference.  Each host in
#           the list will be tried in order until a connection is made.
#           This avoids a single point of failure of either an
#           individual LDAP server *or* the LDAP load balancer.

#  List (array) of LDAP servers and array reference

my @ldap_server   = ('ldap.cedar.uta.edu',
                     'pi.cedar.uta.edu',
                     'xi.cedar.uta.edu');

my $rldap_server  = \@ldap_server;

# However... Ex Libris' Perl LDAP apparently doesn't allow for this
# type of array referencing, so until they upgrade, we will hard code
# the LDAP load balancer...

$rldap_server  = "ldap.cedar.uta.edu";

# Certificate file required for TLS encryption
my $cert_file = "/exlibris/metalib/m3_1/apache/conf/ssl.crt/ca-bundle.crt";

#  Parse form data
my %formdata;
my $bypass_metachar_removal = 'VERIFICATION';
&ReadParse;

##############################################################
#
#  Input:

my $query_string;
if ($ENV{'QUERY_STRING'}) {
    $query_string        = $ENV{'QUERY_STRING'};
} else {
    $query_string        = $formdata{'query_string'};
}
my $net_id               = $formdata{'BOR_ID'};
my $passwd               = $formdata{'VERIFICATION'};
my $institute            = $formdata{'INSTITUTE'};

# Debugging
# &PrintToBrowser($query_string);


&AuthenticatePatron($net_id,$passwd);

############################################################
#  AuthenticatePatron
############################################################
#
#   

sub AuthenticatePatron {
    my ($user_name, $pw) = @_;

    if ((! $user_name) && (! $pw)) {
        &AuthenticationFailure("2","No username and password entered.");
    } elsif (! $user_name) {
        &AuthenticationFailure("2","No username entered.");
    } elsif (! $pw) {
        &AuthenticationFailure("2","No password entered.");
    }

    use Net::LDAP;

    #  Create a new Net::LDAP object and open a connection
    #  to an LDAP server.
    my $ldap = Net::LDAP->new( $rldap_server,
	version => 3,
	port    => 389,
	debug   => 0 )
        or &AuthenticationFailure("1","$@");

    #  Uncomment these lines to determine the LDAP version(s).
    #  Note: LDAPv3 is required for the TLS encryption method below.
    #my $dse = $ldap->root_dse();
    #my $versions   = $dse->get_value('supportedLDAPVersion', asref => 1);
    #print "LDAP versions are @$versions\n";

    #  The start_tls method converts the existing connection to
    #  Transport Layer Security (TLS), which provides encrypted
    #  traffic.  It is an alternative to using LDAPS.  
    #  The verify options are 'none', 'optional', and 'require'.
    #  The most secure option is 'require'.
    #  If you set verify to optional or require, you must also set
    #  either cafile or capath.  If you have installed Apache with
    #  SSL, you can probably use the ca-bundle.crt as your cafile
    #  file, but make sure it has the necessary read permissions.
    my $ldap_result = $ldap->start_tls(
	verify => 'require',
	cafile => "$cert_file"
        );

    #  Uncomment this to see the type of server cipher being used
    #print "$ldap_server cipher: " . $ldap->cipher . "\n";

    my $user = "uid=$user_name, cn=accounts, dc=uta, dc=edu";


    $ldap_result = $ldap->bind("$user", password => "$pw");


    if ($ldap_result->code ne "0") {
        my $error_message = $ldap_result->error;
        &AuthenticationFailure("7","$error_message");
    }

    #  These values are dependent on the particular LDAP
    #  implementation.
    $ldap_result = $ldap->search(
        base   => 'cn=people, dc=uta, dc=edu',
        scope  => 'subtree',
        filter => "(utaAccountName=$user_name)"
        );
    # For debugging
    # warn $ldap_result->error if $ldap_result->code ne "0";

    if ($ldap_result->count() == 1) {
	my $ldap_entry = $ldap_result->entry(0);
	my $user_name     = $ldap_entry->get_value('cn');
	my $empl_status   = $ldap_entry->get_value('utaEmployeeStatus');
	my $empl_title    = $ldap_entry->get_value("utaEmployeeTitle");
	my $stud_status   = $ldap_entry->get_value('utaStudentStatus');
	my $stud_class    = $ldap_entry->get_value('utaStudentClassification');
	my $email_addr    = $ldap_entry->get_value('utaPrimaryEmail');
	my $home_phone    = $ldap_entry->get_value('homePhone');
	my $empl_phone    = $ldap_entry->get_value('utaEmployeePhone');
	my $home_street_1 = $ldap_entry->get_value('utaHomeStreet1');
	my $home_street_2 = $ldap_entry->get_value('utaHomeStreet2');
	my $home_city     = $ldap_entry->get_value('utaHomeCity');
	my $home_state    = $ldap_entry->get_value('utaHomeState');
	my $home_zip      = $ldap_entry->get_value('utaHomeZip');
	my $stud_street_1 = $ldap_entry->get_value('utaStudentHomeStreet1');
	my $stud_street_2 = $ldap_entry->get_value('utaStudentHomeStreet2');
	my $stud_city     = $ldap_entry->get_value('utaStudentHomeCity');
	my $stud_state    = $ldap_entry->get_value('utaStudentHomeState');
	my $stud_zip      = $ldap_entry->get_value('utaStudentHomeZip');

        my $bor_user_name       = $user_name;
        my $bor_institute       = "UTA";
        my $bor_user_email      = $email_addr;
        my $bor_user_phone_1    = $home_phone;
	   $bor_user_phone_1 =~ s/\+1 //;
        my $bor_user_phone_2    = $empl_phone;
	   $bor_user_phone_2 =~ s/\+1 //;
	my $bor_second_affil    = "GUEST";
	my $bor_acad_status     = "Other";
	my $bor_resource_status = "A";

	if ($empl_status =~ /active/i ||
	    $empl_status =~ /future/i ||
	    $empl_status =~ /retired/i) {
	    $bor_second_affil = "STAFF";
        }
	if ($stud_class =~ /freshman/i  ||
	    $stud_class =~ /sophomore/i ||
	    $stud_class =~ /junior/i    ||
	    $stud_class =~ /senior/i    ||
	    $stud_class =~ /degreed/i) {
	    $bor_second_affil = "UNDERGRADUATE";
	    $bor_acad_status  = "Undergraduate";
	} elsif ($stud_class =~ /masters/i  ||
	    $stud_class =~ /doctoral/i) {
	    $bor_second_affil = "GRAD";
	    $bor_acad_status  = "Graduate";
        }
	if ($empl_title =~ /librarian/i) {
	    $bor_resource_status = "T";
	    $bor_acad_status  = "Faculty_Member";
	}
        my ($bor_user_address,$bor_user_city,$bor_user_state,$bor_user_zip);
	if ($home_street_1 && $home_city && $home_state && $home_zip) {
	    $bor_user_address = $home_street_1 . $home_street_2;
	    $bor_user_city    = $home_city;
	    $bor_user_state   = $home_state;
	    $bor_user_zip     = $home_zip;
	} elsif ($stud_street_1 && $stud_city && $stud_state && $stud_zip) {
	    $bor_user_address = $stud_street_1 . $stud_street_2;
	    $bor_user_city    = $stud_city;
	    $bor_user_state   = $stud_state;
	    $bor_user_zip     = $stud_zip;
	}

        &ReturnXMLSuccess($bor_user_name,$bor_user_email,$bor_second_affil,
	    $bor_resource_status,$bor_user_address,$bor_user_city,
	    $bor_user_state,$bor_user_zip,$bor_user_phone_1,$bor_user_phone_2,
	    $bor_acad_status);
    } else {
	&ReturnXMLFailure;
    }


#  For debugging...
#    print "\$ldap_result->count is $max\n";
#    foreach my $entry ($ldap_result->all_entries) { 
#	print "<pre>";
#	$entry->dump; 
#	print "</pre>";
#    }

    $ldap->unbind();
}


############################################################
#  ReturnXMLSuccess
############################################################

sub ReturnXMLSuccess {
    my ($bor_user_name,$bor_user_email,$bor_second_affil,
	$bor_resource_status,$bor_user_address,$bor_user_city,
	$bor_user_state,$bor_user_zip,$bor_user_phone_1,$bor_user_phone_2,
	$bor_acad_status) = @_;
    print "Content-type: text/html\n\n";
    print <<EOSTUFF;
<?xml version="1.0" ?>
<bor_authentication>
  <auth>Y</auth>
</bor_authentication>
<bor_info>
   <id>$net_id</id>
   <z312_group>$bor_second_affil</z312_group>
   <resource_status>$bor_resource_status</resource_status>
   <z312_name>$bor_user_name</z312_name>
   <z312_email_address>$bor_user_email</z312_email_address>
   <z312_address_2>$bor_user_address</z312_address_2>
   <z312_address_3>$bor_user_city</z312_address_3>
   <z312_address_4>$bor_user_state</z312_address_4>
   <z312_zip>$bor_user_zip</z312_zip>
   <z312_telephone_1>$bor_user_phone_1</z312_telephone_1>
   <z312_telephone_2>$bor_user_phone_2</z312_telephone_2>
   <academic_status>$bor_acad_status</academic_status>
   <z312_auth_method>1</z312_auth_method>
   <z312_expiry_date>$bor_expiry_date</z312_expiry_date>
</bor_info>

EOSTUFF
    exit(0);
}


############################################################
#  ReturnXMLFailure
############################################################

sub ReturnXMLFailure {
    my ($bor_user_name,$bor_user_email) = @_;
    print "Content-type: text/html\n\n";
    print <<EOSTUFF;
<?xml version="1.0" ?>
<bor_authentication>
  <auth>N</auth>
</bor_authentication>
EOSTUFF
    exit(0);
}


############################################################
#  RedirectFailure
############################################################

sub RedirectFailure {
    my $redirect_url = "$metalib_base_URL?func=remote-login";
    print "Location: $redirect_url\n\n";
    exit(0);
}


############################################################
#  AuthenticationFailure
############################################################
#
#  When called, this subroutine should be passed two
#  parameters: 1) an exit code, and 2) an error message

sub AuthenticationFailure {
    my ($exit_status, $error_message) = @_;
    # Check that the value passed as an exit
    # status makes sense (i.e. is a digit).
    if (! ($exit_status =~ /\d/) ) {
        $exit_status = 9;
    }
#    `echo "$exit_status : $error_message" | /usr/bin/mailx -s "hook.cgi AuthFail" doran`;
    &ReturnXMLFailure;
    exit($exit_status);
}


############################################################
#  PrintInc
############################################################
#
#  Prints "include" files.
#  Usage: &PrintInc ("../somefile.inc");

sub PrintInc {
    my ($inc_file) = @_;
    open (INCLUDE, "$inc_file")  || warn "Can't open file.\n";
    while (<INCLUDE>) {
      print;
    }
    close (INCLUDE);
}


##########################################################
#  ReadParse
##########################################################
#
#  ReadParse reads in and parses the CGI input.
#  It reads  / QUERY_STRING ("get"  method)
#            \    STDIN     ("post" method)

sub ReadParse {
    my ($meth, $formdata, $pair, $name, $value);

    # Retrieve useful ENVIRONMENT VARIABLES
    $meth = $ENV{'REQUEST_METHOD'};

    # If method unspecified or if method is GET
    if ($meth eq  '' || $meth eq 'GET') {
        # Read in query string
        $formdata = $ENV{'QUERY_STRING'};
    }
    # If method is POST
    elsif ($meth eq 'POST') {
        read(STDIN, $formdata, $ENV{'CONTENT_LENGTH'});
    }
    else {
        die "Unknown request method: $meth\n";
    }

    # name-value pairs are separated and put into a list array
    my @pairs = split(/&/, $formdata);

    foreach $pair (@pairs) {
        # names and values are split apart
        ($name, $value) = split(/=/, $pair);
        # pluses (+'s) are translated into spaces
        $value =~ tr/+/ /;
        # hex values (%xx) are converted to alphanumeric
        $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
        # The code below attempts to ferret out shell meta-characters
        # in the form input.  It replaces them with spaces.
        # looking for the presence of shell meta-characters in $name
        $name  =~ s/[{}\!\$;><&\*'\|]/ /g;
        # looking for the presence of shell meta-characters in $value
        # and also let password value bypass this check, since secure
        # passwords will often have non alphanumeric values.
        if ( $name ne "$bypass_metachar_removal") {
            $value =~ s/[{}\!\$;><\*'\|]/ /g;
        }
        # associative array of names and values created
        $formdata{$name} = $value;
    }
}

exit(0);