Home Contact
Validate the HTML of this page

External Authentication

Adaptor Example


#!/usr/local/bin/perl -w

#############################################################
#
#  Perl script: login.cgi
#      Version: 1.3
#
#  2005-2006, Michael Doran, doran@uta.edu
#  University of Texas at Arlington
#
#  This script is a customer-created adaptor as required
#  to implement Voyager external patron authentication.
#
#  Designed to run on the Voyager database server.
#  Accommodates a separate WebVoyage server.
#
#  Requires these Perl modules:
#	Net::LDAP
#	DBI
#	DBD::Oracle 
#
#  Relevant WebVoyage server opac.ini settings:
#
#    [ExtAuthenticationSystem]
#    ExtAuthSystemEnabled=Y
#    ExtAuthBypassLoginScreen=Y
#    ExtAuthSystemURL=http[s]://vygrdb.svr.edu/cgi-bin/login.cgi


#  Best practice

use strict;

#  

use DBI;

#  Some script variables

my $this_script = "/cgi-bin/login.cgi";
my $page_title  = "Patron Login";
my $version     = "1.3";

#  If run on a separate WebVoyage server
#  Also modify the action attribute of the form tag in the 
#  login HTML form for the "traditional" way.

my $webvoyage_base_URL = "https://webvoyage.univ.edu";
my $pwebrecon_base_URL = "$webvoyage_base_URL/cgi-bin/Pwebrecon.cgi?";


#############################################################
#
#  LDAP server variables
#
#  University of Texas at Arlington LDAP servers:
#	    ldap.univ.edu  -  LDAP server load balancer
#         ldap01.univ.edu  -  individual LDAP server 
#         ldap02.univ.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.univ.edu',
                     'ldap01.univ.edu',
                     'ldap02.univ.edu');

my $rldap_server  = \@ldap_server;

#  Attribute from the LDAP record whose value will be matched
#  against the values in PATRON.NORMAL_INSTITUTION_ID in Voyager

my $ldap_iid_attr = "univID";

##############################################################
#
#  Voyager/Oracle variables
#
#  This script executes an Oracle DML (Data Manipulation
#  Language) statement (i.e. "insert"), so a "read-only"
#  Oracle username and password can NOT be used.  You
#  MUST use the production username and password.  Your
#  production username/password are the values for USERPASS
#  in your voyager.env file.

$ENV{ORACLE_SID}    = "******";
$ENV{ORACLE_HOME}   = "/oracle/app/oracle/product/9.2.0";
my $ora_db_username = "******";
my $ora_db_password = "******";
my $db_name         = "******";
my $db_table        = "wopac_pid_patron_keys";
  
my ($user_name,$pw);

#  Parse form data
my %formdata;
&ReadParse;

##############################################################
#
#  Input:
#   - passed from WebVoyage (Pwebrecon), or
#   - the login form 
#

my $query_string;
if ($ENV{'QUERY_STRING'}) {
    $query_string        = $ENV{'QUERY_STRING'};
} else {
    $query_string        = $formdata{'query_string'};
}
my $pid                  = $formdata{'PID'};
my $seq                  = $formdata{'SEQ'};
my $pweb_page            = $formdata{'PAGE'};
my $patron_ext_username  = $formdata{'ext_id'};
my $patron_ext_password  = $formdata{'ext_pw'};
my $external             = $formdata{'external'};

my $cred_type            = "NetID";

#  Sometimes it's helpful to have this line towards the
#  top of a script that normally outputs to the web...
#print "Content-type: text/html\n\n";

#  Logic on what to do based on the input  
if ($external) {
    &AuthenticatePatron("$patron_ext_username", "$patron_ext_password");
} else {
    if ($pid) {
        &PrintLoginForm;
    } else {
        # If the login script URL is bookmarked, this will get it via
	# a detour thru Pwebrecon.cgi in order to pick up a valid PID
        print "Location: $webvoyage_base_URL/cgi-bin/Pwebrecon.cgi?DB=local&PAGE=pbLogon\n\n";
    }
}


############################################################
#  PrintLoginForm
############################################################

sub PrintLoginForm {
    my ($message) = @_;
    # Location of your HTML login form components, in 
    # relation to your Voyager cgi-bin directory
    my $form_dir = "../html/adaptor";
    print "Content-type: text/html\n\n";
    print qq(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">

<head>
  <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
  <link rel="stylesheet" type="text/css" href="/css/login.css" />
);
    &PrintInc ("../html/header.htm");
    if ($pid) {
	&PrintButtons;
    }
    if ($message) {
        print "<b>$message</b>" . "\n";
    }
    print qq(
<br />
<table align="center" cellpadding="12">
  <tr>
    <td class="tdform">
      <form action="/cgi-bin/login.cgi" method="post">
        <br />
      <table cellpadding="8">
        <tr>
          <th>Students, faculty, &amp; staff</th>
        </tr>
        <tr>
          <td class="right">  
            <b>NetID:</b>    <input name="ext_id" type="text"     size="20" /><br />
            <b>Password:</b> <input name="ext_pw" type="password" size="20" /><br />
          </td>
        </tr>
      </table>
        <br />
    );
    if ($pid) {
        print qq(\t<input type="hidden" name="PID" value="$pid" />\n);
    }
    if ($query_string) {
        print qq(\t<input type="hidden" name="query_string" value="$query_string" />\n);
    }
    print qq(
        <input type="submit" value="NetID Login" name="external" />
      </form>
    </td>
    <td class="divider">
        OR
        <br />
        &nbsp;
    </td>
    <td class="tdform">
      <form name="logonpage" action="$webvoyage_base_URL/cgi-bin/Pwebrecon.cgi" method="post" 
        autocomplete="OFF" enctype="application/x-www-form-urlencoded">
        <br />
      <table cellpadding="8">
        <tr>
          <th><a href="http://someurl.edu">Guest Borrowers</a></th>
        </tr>
        <tr>
          <td class="right">    
            Barcode:    <input name="BC" type="password" size="20" /><br />
            Last Name: <input name="LN" type="text"     size="20" /><br />
          </td>
        </tr>
      </table>
        <br />
    );
    if ($pid) {
        print qq(\t<input type="hidden" name="PID" value="$pid" />\n);
    }
    if ($seq) {
        print qq(\t<input type="hidden" name="SEQ" value="$seq" />\n);
    }
    if ($pweb_page) {
        print qq(\t<input type="hidden" name="PAGE" value="$pweb_page" />\n);
    }
    print qq(
        <input type="hidden" name="LGNT" value="0" />   
        <input type="submit" value="Barcode Login" name="internal" />
      </form>
    </td>
  </tr>
</table>

</body>
</html>
    );
    exit(0);
}


############################################################
#  PrintButtons
############################################################
sub PrintButtons {
    my $uta_prefix = "$webvoyage_base_URL/images/";
    print <<EOFSTUFF;
<br />
<div align="center">
<a href="$pwebrecon_base_URL\PAGE=sbSearch&SEQ=$seq&PID=$pid">
<img src="${uta_prefix}UpSearch.gif" alt="Back to Catalog" border="0" /></a>
<img src="${uta_prefix}DownLogin.gif" alt="Login Page" border="0" />
<a href="$webvoyage_base_URL/help/login.htm">
<img src="${uta_prefix}UpHelp.gif" alt="Help" border="0" /></a>
<a href="$pwebrecon_base_URL\PAGE=Exit&SEQ=$seq&PID=$pid">
<img src="${uta_prefix}UpExit.gif" alt="Exit" border="0" /></a>
</div>
EOFSTUFF
}


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

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

    if ((! $user_name) && (! $pw)) {
        &AuthenticationFailure("2","No $cred_type username and password entered.");
    } elsif (! $user_name) {
        &AuthenticationFailure("2","No $cred_type username entered.");
    } elsif (! $pw) {
        &AuthenticationFailure("2","No $cred_type 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 $mesg = $ldap->start_tls(
	verify => 'require',
	cafile => '/usr/local/apache/conf/ssl.crt/ca-bundle.crt'
        );

    #  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";

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

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

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

    my $max = $mesg->count; 

    my $institution_id;
    if ($max == 1) {
	my @entries = $mesg->entries;
        my $entr ;
        foreach $entr ( @entries ) {
            foreach my $attr (sort $entr->attributes) {
                if ($attr eq "$ldap_iid_attr") {
                   $institution_id = $entr->get_value("$ldap_iid_attr");
                }
            }
        }
        if ($institution_id) {
            &InsertPatronInfo($pid,$institution_id);
	    &Redirect("success");
        } else {
            &AuthenticationFailure(5,"LDAP record lacks required attribute.");
        }
    } else {
	&Redirect("failure");
    }


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

    $ldap->unbind();
}

##########################################################
#  InsertPatronInfo
##########################################################
#
#

sub InsertPatronInfo {
    my ($pid, $institution_id) = @_;
    use DBI;
    my ($dbh,$sth);

    $dbh = DBI->connect('dbi:Oracle:', $ora_db_username, $ora_db_password,
	{AutoCommit => 1}) || die "Could not connect: $DBI::errstr\n";

    # Clean out any "orphan" entries in the wopac_pid_patron_keys table
    # that are associated with this patron.

    my $sql_string = "delete from $db_name.$db_table where 
	$db_name.$db_table.pid = '$pid' or
        $db_name.$db_table.patron_key = '$institution_id'";

    $sth = $dbh->prepare($sql_string) || warn $dbh->errstr;

    $sth->execute || warn $dbh->errstr;

    $sth->finish;

    # Insert the PID and Institution ID values into the
    # wopac_pid_patron_keys table.

    $sql_string = "insert into $db_name.$db_table (pid, patron_key)
	values ('$pid','$institution_id')";

    $sth = $dbh->prepare($sql_string) || warn $dbh->errstr;

    $sth->execute || warn $dbh->errstr;

    $sth->finish;
    $dbh->disconnect;
}


############################################################
#  Redirect
############################################################
#

sub Redirect {
    my ($result) = @_;
    my $redirect_url = "$webvoyage_base_URL/cgi-bin/Pwebrecon.cgi?$query_string&authenticate=";
    if ($result =~ /success/i) {
        $redirect_url .= "Y";
    } else {
        $redirect_url .= "N";
    }
    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;
    }
    &PrintLoginForm ("Authentication Failed: $error_message\n");
    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;
        if ( $name ne "PID") {
            $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
        # NOTE: Removed "&" for the WebVoyage alternate login script!
        # and also let password value bypass this check, since secure
        # passwords will often have non alphanumeric values.
        if ( $name ne "ext_pw" && $name ne "PID" ) {
            $value =~ s/[{}\!\$;><\*'\|]/ /g;
        }
        # associative array of names and values created
        $formdata{$name} = $value;
    }
}

exit(0);