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');

my $contextUrl = 'http://' . $properties->getProperty('server.name') . ':' .

                 $properties->getProperty('server.httpPort') . '/' .

                 $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');

my $searchBase;

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);

my @orgList;

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

    push(@orgList, $oKey);

}

foreach my $o (@orgList) {

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

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

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

    } else {

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

    }

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

    my $errorMessage = 0;

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

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

    if ($bindresult->code) {

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

    }

    # Find the user here and change their entry

    my $newpass = createSeededPassHash($userPass);

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

    my $result = $ldap->modify( $userDN, replace => { %$modifications });

    if ($result->code()) {

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

                           "<br />\n" . $result->error;

    }

    $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 ($bindresult->code) {

        return $entry;

    }

        $entry = $mesg->pop_entry;

        $ldap->unbind;   # take down session

    } else {

        $ldap->unbind;   # take down session

        # Follow references by recursive call to self

        my @references = $mesg->references();

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

            my $uri = URI->new($references[$i]);

            my $host = $uri->host();

            my $path = $uri->path();

            $path =~ s/^\///;

            $entry = &getLdapEntry($host, $path, $username, $org);

            if ($entry) {

                return $entry;

            }

        }

    }

    return $entry;

}

#

# send an email message notifying the user of the pw change

#

sub sendPasswordNotification {

    my $username = shift;

    my $org = shift;

    my $newPass = shift;

    my $recipient = shift;

    my $errorMessage = "";

    if ($recipient) {

        my $sender =  $properties->getProperty('email.sender');

        my $smtp = Net::SMTP->new($mailhost);

        $smtp->mail($sender);

        $smtp->to($recipient);

        my $message = <<"        ENDOFMESSAGE";

        To: $recipient

        From: $sender

        Subject: KNB Password Reset

        Somebody (hopefully you) requested that your KNB password be reset.

        This is generally done when somebody forgets their password.  Your

        password can be changed by visiting the following URL:

            Username: $username

        Organization: $org

        New Password: $newPass

        Thanks,

            The KNB Development Team

        ENDOFMESSAGE

        $message =~ s/^[ \t\r\f]+//gm;

        $smtp->data($message);

        $smtp->quit;

    } else {

        $errorMessage = "Failed to send password because I " .

                        "couldn't find a valid email address.";

    }

    return $errorMessage;

}

#

# search the LDAP directory to see if a similar account already exists

#

sub findExistingAccounts {

    my $ldapurl = shift;

    my $base = shift;