Metacat

#!/usr/bin/perl -w

#  '$RCSfile$'

#  Copyright: 2001 Regents of the University of California

#

#   '$Author$'

#     '$Date$'

# '$Revision$'

#

# This program is free software; you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# the Free Software Foundation; either version 2 of the License, or

# (at your option) any later version.

#

# This program is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

# You should have received a copy of the GNU General Public License

# along with this program; if not, write to the Free Software

# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#

#

# This is a web-based application for allowing users to register a new

# account for Metacat access.  We currently only support LDAP even

# though metacat could potentially support other types of directories.

use lib '../WEB-INF/lib';

use Template;           # load the template-toolkit module

use Net::SMTP;          # load the SMTP net libraries

use Digest::SHA1;       # for creating the password hash

use MIME::Base64;       # for creating the password hash

use URI;                # for parsing URL syntax

use Config::Properties; # for parsing Java .properties files

use File::Basename;     # for path name parsing

my $workingDirectory = dirname($cgiUrl);

my $metacatProps = "${workingDirectory}/../WEB-INF/metacat.properties";

my $properties = new Config::Properties();

unless (open (METACAT_PROPERTIES, $metacatProps)) {

        $workingDirectory .", is this correct?";

    exit(0);

}

my $skinsDir = "${workingDirectory}/../style/skins";

my $templatesDir = abs_path("${workingDirectory}/../style/common/templates");

my $tempDir = $properties->getProperty('application.tempDir');

# url configuration

my $server = $properties->splitToTree(qr/\./, 'server');

if ($properties->getProperty('server.httpPort') ne '80') {

        $contextUrl = $contextUrl . ':' . $properties->getProperty('server.httpPort');

}

$contextUrl = $contextUrl . '/' .  $properties->getProperty('application.context');

my $metacatUrl = $contextUrl . "/metacat";

my $cgiPrefix = "/" . $properties->getProperty('application.context') . "/cgi-bin";

my $styleSkinsPath = $contextUrl . "/style/skins";

my $styleCommonPath = $contextUrl . "/style/common";

my @errorMessages;

my $error = 0;

# Import all of the HTML form fields as variables

import_names('FORM');

# Must have a config to use Metacat

my $skinName = "";

if ($FORM::cfg) {

    $skinName = $FORM::cfg;

} elsif ($ARGV[0]) {

    $skinName = $ARGV[0];

} else {

}

# Metacat isn't initialized, the registry will fail in strange ways.

if (!($metacatUrl)) {

    'Registry Error: Metacat is not initialized! Make sure' .

        ' MetacatUrl is set correctly in ' .  $skinName . '.cfg';

    exit();

}

my $skinProperties = new Config::Properties();

if (!($skinName)) {

    $error = "Application misconfigured.  Please contact the administrator.";

    push(@errorMessages, $error);

} else {

    my $skinProps = "$skinsDir/$skinName/$skinName.properties";

    unless (open (SKIN_PROPERTIES, $skinProps)) {

        print "Content-type: text/html\n\n";

        print "Unable to locate skin properties at $skinProps.  Is this path correct?";

        exit(0);

    }

    $skinProperties->load(*SKIN_PROPERTIES);

}

my $config = $skinProperties->splitToTree(qr/\./, 'registry.config');

#           NRS skin instead of metacat.properties. The intent is to prevent editing

#           of our core properties file, which is manipulated purely through the web.

#           Once organizations are editable, this section should be removed as should

#           the properties within nrs/nrs.properties.

my $nrsProperties = new Config::Properties();

my $nrsProps = "$skinsDir/nrs/nrs.properties";

unless (open (NRS_PROPERTIES, $nrsProps)) {

    print "Content-type: text/html\n\n";

    print "Unable to locate skin properties at $nrsProps.  Is this path correct?";

    exit(0);

}

$nrsProperties->load(*NRS_PROPERTIES);

my $nrsConfig = $nrsProperties->splitToTree(qr/\./, 'registry.config');

# XXX END HACK

my $ldapUsername;

my $ldapPassword;

# TODO: the default tree for accounts should be exposed somewhere, defaulting to unaffiliated

my $ldapurl = $properties->getProperty('auth.url');

# Java uses miliseconds, Perl expects whole seconds

my $query = new CGI;

#--------------------------------------------------------------------------80c->

# Set up the Template Toolkit to read html form templates

my $templates = $properties->splitToTree(qr/\./, 'ldap.templates');

$$templates{'footer'} = $skinProperties->getProperty("registry.templates.footer");

# set some configuration options for the template object

             INCLUDE_PATH => $templatesDir,

             INTERPOLATE  => 0,

             POST_CHOMP   => 1,

             DEBUG        => 1,

# create an instance of the template

my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');

my $orgNames = $properties->splitToTree(qr/\./, 'organization.name');

# pull out properties available e.g. 'name', 'base'

my @orgData = keys(%$orgProps);

while (my ($oKey, $oVal) = each(%$orgNames)) {

    push(@orgList, $oKey);

}

foreach my $o (@orgList) {

        $ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");

    if ($o eq 'UCNRS') {

        $ldapConfig->{'UCNRS'}{'base'} = $nrsConfig->{'base'};

        $ldapConfig->{'UCNRS'}{'user'} = $nrsConfig->{'username'};

        $ldapConfig->{'UCNRS'}{'password'} = $nrsConfig->{'password'};

    }

    if (!$ldapConfig->{$o}{'base'}) {

        $ldapConfig->{$o}{'base'} = $authBase;

    }

    # include filter information. By default, our filters are 'o=$name', e.g. 'o=NAPIER'

    # these can be overridden by specifying them in metacat.properties. Non-default configs

    # such as UCNRS must specify all LDAP properties.

    if ($ldapConfig->{$o}{'base'} eq $authBase) {

        my $filter = "o=$o";

        if (!$ldapConfig->{$o}{'org'}) {

            $ldapConfig->{$o}{'org'} = $filter;

        }

        if (!$ldapConfig->{$o}{'filter'}) {

            $ldapConfig->{$o}{'filter'} = $filter;

        }

        # also include DN, which is just org + base

        if ($ldapConfig->{$o}{'org'}) {

            $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'org'} . "," . $ldapConfig->{$o}{'base'};

        }

        $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'base'};

    }

    # set LDAP administrator user account

        $ldapConfig->{$o}{'user'} = $ldapConfig->{'unaffiliated'}{'user'};

    my @userParts = split(',', $ldapConfig->{$o}{'user'});

    if (scalar(@userParts) == 1) {

        $ldapConfig->{$o}{'user'} = $ldapConfig->{$o}{'user'} . "," . $ldapConfig->{$o}{'base'};

    }

    if (!$ldapConfig->{$o}{'password'}) {

        $ldapConfig->{$o}{'password'} = $ldapConfig->{'unaffiliated'}{'password'};

    }

#--------------------------------------------------------------------------80c->

# Define the main program logic that calls subroutines to do the work

#--------------------------------------------------------------------------80c->

# The processing step we are handling

my $cfg = $query->param('cfg');

# define the possible stages

my %stages = (

              'initregister'      => \&handleInitRegister,

              'register'          => \&handleRegister,

              'registerconfirmed' => \&handleRegisterConfirmed,

              'simplesearch'      => \&handleSimpleSearch,

              'initaddentry'      => \&handleInitAddEntry,

              'addentry'          => \&handleAddEntry,

              'initmodifyentry'   => \&handleInitModifyEntry,

              'modifyentry'       => \&handleModifyEntry,

              'initchangepass'    => \&handleInitialChangePassword,

if ( $stages{$stage} ) {

  $stages{$stage}->();

} else {

  &handleResponseMessage();

}

#--------------------------------------------------------------------------80c->

# Define the subroutines to do the work

#--------------------------------------------------------------------------80c->

    my $templateList = shift;

    my $templateVars = setVars(shift);

    foreach my $tmpl (@{$templateList}) {

        $template->process( $templates->{$tmpl}, $templateVars );

    }

    $template->process( $templates->{'footer'}, $templateVars );

}

# create the initial registration form

#

sub handleInitRegister {

  my $vars = shift;

  print "Content-type: text/html\n\n";

  # process the template files:

}

#

# process input from the register stage, which occurs when

# a user submits form data to create a new account

#

sub handleRegister {

    print "Content-type: text/html\n\n";

    my $allParams = { 'givenName' => $query->param('givenName'),

                      'sn' => $query->param('sn'),

                      'o' => $query->param('o'),

                      'mail' => $query->param('mail'),

                      'uid' => $query->param('uid'),

                      'userPassword' => $query->param('userPassword'),

                      'userPassword2' => $query->param('userPassword2'),

                      'title' => $query->param('title'),

                      'telephoneNumber' => $query->param('telephoneNumber') };

    # Check that all required fields are provided and not null

    my @requiredParams = ( 'givenName', 'sn', 'o', 'mail',

                           'uid', 'userPassword', 'userPassword2');

    if (! paramsAreValid(@requiredParams)) {

        my $errorMessage = "Required information is missing. " .

            "Please fill in all required fields and resubmit the form.";

                                     allParams => $allParams,

                                     errorMessage => $errorMessage });

        exit();

    # Search LDAP for matching entries that already exist

    # Some forms use a single text search box, whereas others search per

    # attribute.

    my $filter;

    if ($query->param('searchField')) {

      $filter = "(|" .

                "(uid=" . $query->param('searchField') . ") " .

                "(mail=" . $query->param('searchField') . ")" .

                "(&(sn=" . $query->param('searchField') . ") " .

                "(givenName=" . $query->param('searchField') . "))" .

                ")";

    } else {

      $filter = "(|" .

                "(uid=" . $query->param('uid') . ") " .

                "(mail=" . $query->param('mail') . ")" .

                "(&(sn=" . $query->param('sn') . ") " .

                "(givenName=" . $query->param('givenName') . "))" .

                ")";

    }

    my @attrs = [ 'uid', 'o', 'cn', 'mail', 'telephoneNumber', 'title' ];

    my $found = findExistingAccounts($ldapurl, $searchBase, $filter, \@attrs);

    # If entries match, send back a request to confirm new-user creation

    if ($found) {

                                                     allParams => $allParams,

                                                     foundAccounts => $found });

    } else {

        createAccount($allParams);

    }

    exit();

}

#

# process input from the registerconfirmed stage, which occurs when

# a user chooses to create an account despite similarities to other

# existing accounts

#

sub handleRegisterConfirmed {

    my $allParams = { 'givenName' => $query->param('givenName'),

                      'sn' => $query->param('sn'),

                      'uid' => $query->param('uid'),

                      'userPassword' => $query->param('userPassword'),

                      'userPassword2' => $query->param('userPassword2'),

                      'title' => $query->param('title'),

                      'telephoneNumber' => $query->param('telephoneNumber') };

    print "Content-type: text/html\n\n";

    createAccount($allParams);

    exit();

}

#

# change a user's password upon request

#

sub handleChangePassword {

    print "Content-type: text/html\n\n";

    my $allParams = { 'test' => "1", };

    if ($query->param('uid')) {

        $$allParams{'uid'} = $query->param('uid');

    }

    if ($query->param('o')) {

        $$allParams{'o'} = $query->param('o');

    # Check that all required fields are provided and not null

    my @requiredParams = ( 'uid', 'o', 'oldpass',

                           'userPassword', 'userPassword2');

    if (! paramsAreValid(@requiredParams)) {

        my $errorMessage = "Required information is missing. " .

            "Please fill in all required fields and submit the form.";

                                        allParams => $allParams,

                                        errorMessage => $errorMessage });

        exit();

    # We have all of the info we need, so try to change the password

    if ($query->param('userPassword') =~ $query->param('userPassword2')) {

        $ldapUsername = $ldapConfig->{$o}{'user'};

        $ldapPassword = $ldapConfig->{$o}{'password'};

            my $errorMessage = changePassword(

                    $dn, $query->param('userPassword'),

                    $dn, $query->param('oldpass'), $query->param('o'));

                                                allParams => $allParams,

                                                errorMessage => $errorMessage });

                exit();

                                                       allParams => $allParams });

                exit();

        }

    } else {

        my $errorMessage = "The passwords do not match. Try again.";

                                        allParams => $allParams,

                                        errorMessage => $errorMessage });

        exit();

}

#

# only display chagepass template without any error

#

sub handleInitialChangePassword {

    print "Content-type: text/html\n\n";

    my $allParams = { 'test' => "1", };

    my $errorMessage = "";

                                    errorMessage => $errorMessage });

    exit();

#

#

sub handleResetPassword {

    print "Content-type: text/html\n\n";

    my $allParams = { 'test' => "1", };

    if ($query->param('uid')) {

        $$allParams{'uid'} = $query->param('uid');

    }

    if ($query->param('o')) {

        $$allParams{'o'} = $query->param('o');

    # Check that all required fields are provided and not null

    my @requiredParams = ( 'uid', 'o' );

    if (! paramsAreValid(@requiredParams)) {

        my $errorMessage = "Required information is missing. " .

            "Please fill in all required fields and submit the form.";

                                        allParams => $allParams,

                                        errorMessage => $errorMessage });

        exit();

    # We have all of the info we need, so try to change the password

    my $o = $query->param('o');

        exit();

        my $errorMessage = "";

        my $recipient;

        my $userPass;

        my $entry = getLdapEntry($ldapurl, $searchBase,

                $query->param('uid'), $query->param('o'));

        if ($entry) {

            $recipient = $entry->get_value('mail');

            $userPass = getRandomPassword();

            $errorMessage = "User not found in database.  Please try again.";

        }

        if ($errorMessage) {

                                           allParams => $allParams,

                                           errorMessage => $errorMessage });

            exit();

            my $errorMessage = sendPasswordNotification($query->param('uid'),

                                                  allParams => $allParams,

                                                  errorMessage => $errorMessage });

            exit();

    }

}

#

# only display resetpass template without any error

#

sub handleInitialResetPassword {

    print "Content-type: text/html\n\n";

    my $errorMessage = "";

                                   errorMessage => $errorMessage });

    exit();

#

#

sub getRandomPassword {

    my $length = shift;

    if (!$length) {

        $length = 8;

    }

    my $newPass = "";

    my @chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(! @ $ ^) );

    $newPass = join("", @chars[ map { rand @chars } ( 1 .. $length ) ]);

    return $newPass;

}

#

# Change a password to a new value, binding as the provided user

#

sub changePassword {

    my $userDN = shift;

    my $userPass = shift;

    my $bindDN = shift;

    my $bindPass = shift;

    my $o = shift;

    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);

        debug("changePassword: attempting to bind to $bindDN");

        my $bindresult = $ldap->bind( version => 3, dn => $bindDN,

            $errorMessage = "Failed to log in. Are you sure your connection credentails are " .

                            "correct? Please correct and try again...";

            return $errorMessage;

        }

    	my $newpass = createSeededPassHash($userPass);

    	my $modifications = { userPassword => $newpass };

        	$errorMessage = "There was an error changing the password:" .

    	$ldap->unbind;   # take down session

    }

    return $errorMessage;

}

#

# generate a Seeded SHA1 hash of a plaintext password

#

sub createSeededPassHash {

    my $secret = shift;

    my $salt = "";

    for (my $i=0; $i < 4; $i++) {

        $salt .= int(rand(10));

    }

    my $ctx = Digest::SHA1->new;

    $ctx->add($secret);

    $ctx->add($salt);

    my $hashedPasswd = '{SSHA}' . encode_base64($ctx->digest . $salt ,'');

    return $hashedPasswd;

}

#

# Look up an ldap entry for a user

#

sub getLdapEntry {

    my $ldapurl = shift;

    my $base = shift;

    my $username = shift;

    my $org = shift;

    my $entry = "";

    my $mesg;

    #if main ldap server is down, a html file containing warning message will be returned

    if ($ldap) {

    	$ldap->start_tls( verify => 'none');

    	my $bindresult = $ldap->bind;

    	if ($bindresult->code) {

        	return $entry;

    	}

                  "(&(uid=$username)($ldapConfig->{$org}{'filter'})");