#!/perl/bin/perl -T
# Change shebang as appropiate
# IBU Repair Password Management (irs-pass.pl)

#######################################
# Copyright ALARIS Medical Systems 2002
# Version 1.01             17 July 2002
# GNU GPL terms of distribution
#######################################

use warnings;									# DISABLE this on IIS in production
use diagnostics;								# DISABLE in production
use strict;									# 
use lib '.';                  					# Taint mode removes this from @INC

use 5.6.1;									# Start with a recent version of Perl
use IRS_Utils;
use CGI;									# Does all the smarts
use CGI::Carp qw/fatalsToBrowser/;				# Deal with error messages properly
use Digest::SHA1;								# To create the SHA1 password hashes
use Fcntl qw(:DEFAULT :flock);					# Get the File System constants
use Net::SMTP;									# Send an email if we can

use subs qw(load_password_file password_form user_lock
            make_password_digest save_password_file
            local_sanity_checks verify_password
            open_and_die send_email);		

#	#####
#	START
#	#####


cgi_settings;
my $q = CGI->new;
my %settings = %{get_settings("pass")};

local_sanity_checks $q;
my $user = $q->param("REMOTE_USER");
tad $q, "Runtime error: No username specified." unless $user;

my $old_password   = $q->param("password1");
my $new_password_1 = $q->param("password2");
my $new_password_2 = $q->param("password3");

if ($old_password &&
    $new_password_1 &&
    $new_password_2) {
    	tad $q, "The new passwords are not the same.\n<br />Please try again." unless $new_password_1 eq $new_password_2;
		tad $q, "The new password is the same as the old one.\n<br />Please try again." if $new_password_1 eq $old_password;

		verify_password $new_password_1, $q;

		user_lock $q, $settings{write_lock};
    	my ($password_list, $file_digest) = load_password_file $q, $user, $settings{htpassfile};
    	my $old_digest = make_password_digest($old_password);
    	open_and_die $q, "Old password does not match the password in the file." unless $old_digest eq $file_digest;

    	my $new_digest = make_password_digest($new_password_1);
    	
    	my @new_password_list = grep !/^$user/, @$password_list;
    	push @new_password_list, ($user . ":{SHA}" . $new_digest . "=");
    	save_password_file $q, $settings{htpassfile}, \@new_password_list;
    	user_lock $q, $settings{write_lock}, 'open';
    	
    	print $q->header,
    	      $q->hr, $q->h1("Password Changed."),
    	      $q->hr, $q->p("You should close your browser down and restart it.");
    	      $q->hr;

    	send_email $q, $user, $new_password_1, $settings{smtp_server} if $settings{smtp_server};
} else {
    	password_form
}
clean_exit;



#	-------------
#	Sanity checks
#	-------------
sub local_sanity_checks {
	my $q = shift;
	tad $q, "Runtime error: Can only be run via CGI." unless $q->request_method;
	tad $q, "The Administrator has locked the password file.\n<br />Please try again later." if -e $settings{admin_lock};
	tad $q, "Configuration error: The password file has not been configured" unless $settings{htpassfile};
	tad $q, "Runtime error: The specified password file is missing." unless -e $settings{htpassfile};
	tad $q, "Runtime error: The password file is empty." if -z _;
	tad $q, "Runtime error: Unable to read password file." unless -r _;
	tad $q, "Runtime error: Unable to write to password file." unless -w _;
}


#	----------------------
#	Load the Password File
#	----------------------
sub load_password_file {
	my $q    = shift;
	my $user = shift;
	my $file = shift;
	
	open PASS_FILE, "<", $file or tad $q, "Runtime error: Unable to open password file.";
	my @people = <PASS_FILE>;
	close PASS_FILE;

	my @person = grep /^$user/, @people;
	open_and_die $q, "Runtime error: Syntax error in password file." if @person > 1;
	open_and_die $q, "User $user is not in the password file.\n<br />Please contact admin for a username." if @person < 1;

	my ($name, $digest) = split /}/, $person[0];
	chomp $digest;
	chop $digest;
	return \@people, $digest;
}


#	----------------------------------
#	Save the Password file out to disk
#	----------------------------------
sub save_password_file {
	my $q        = shift;
	my $filename = shift;
	my $p_list   = shift;

	my $new_filename = $filename . ".new";
	my $old_filename = $filename . ".old";

	open PASS_FILE, ">", $new_filename or tad $q, "Runtime error: Unable to write to password file";
	flock PASS_FILE, LOCK_EX;
	foreach (@$p_list) {
		print PASS_FILE;
	}
	print PASS_FILE "\n";
	flock PASS_FILE, LOCK_UN;
	close PASS_FILE;

	open_and_die $q, "The Administrator has locked the password file.\n<br />Please try again later." if -e $settings{admin_lock};
	rename $filename, $old_filename;
	rename $new_filename, $filename;
}

#	-------------------------------------
#	Verify that a password is good enough
#	-------------------------------------
sub verify_password {
	my $password = shift;
	my $q = shift;
	
	tad $q, "Password is not long enough.\n<br/>Please use 6 characters or more." if (length $password) < 6;
	tad $q, "Password is not strong enough.\n<br />Please use some chatacters other than just letters and numbers." unless $password =~ /\W/;
}


#	----------------------------------------
#	Make a SHA1 Password Digest for the user
#	----------------------------------------
sub	make_password_digest{
	my $ctx = Digest::SHA1->new;
	$ctx->add(shift);
	return $ctx->b64digest;
}


#	-------------------------
#	Print out a password form
#	-------------------------
sub password_form {

	print $q->header,
	      $q->start_form(-method => 'POST',
	                     -name   => 'form',
	                     -action => '/repair/ibu-repair-passman.html'),
	      $q->table({-class  => 'form'},
	                       $q->Tr($q->th("Old Password:"),
	                       $q->td($q->password_field(-name => 'password1', -size => '15', -maxlength => '30'))),
	                $q->Tr($q->th("New Password:"),
	                       $q->td($q->password_field(-name => 'password2', -size => '15', -maxlength => '30'))),
	                $q->Tr($q->th("New Password:"),
	                       $q->td($q->password_field(-name => 'password3', -size => '15', -maxlength => '30'))),
	                $q->Tr($q->td({-class => 'submit', -colspan => '2'},$q->submit(-name => 'submit', -value => 'Change Password')))),
	      $q->hidden(-name => 'cache', -value => 'off'),
	      $q->end_form,
}


#	------------------------
#	Open and close user lock
#	------------------------
sub	user_lock {
	my $q      = shift;
	my $file   = shift;
	my $open   = shift;

	if ($open) {
		unlink $file if -e $file;
	} else {
		my $escape;
		while (-e $file) {
			tad $q, "The password file has been locked by another user.\n<br/>Please try again shortly." if $escape >= 10;
			$escape++;
			sleep (1);
		}
		sysopen (LOCK_FILE, $file, O_WRONLY | O_EXCL |O_CREAT) or tad $q, "The password file has been locked by another user.\n<br/>Please try again shortly.";
		close LOCK_FILE;
	}
}


#	-----------------------
#	Open Lock and Terminate
#	-----------------------
sub open_and_die {
	my $q       = shift;
	my $message = shift;

	user_lock $q, $settings{write_lock}, 'open';
	tad $q, $message;
}


#	-------------------------
#	Send a confirmation email
#	-------------------------
sub send_email {
	my $q      = shift;
	my $user   = shift;
	my $pass   = shift;
	my $server = shift;
	my $address=  lc($user) . "\@alarismed.com";
	
	my $smtp = Net::SMTP->new($server, Timeout => 30);

	if ($smtp &&
	    $smtp->mail($address) &&
	    $smtp->to($address) &&
	    $smtp->data())
	    {
		$smtp->datasend("Subject: IBU Service Management Password Change Confirmation\n" .
		                "To: $address\n\n" .
		                "User: $user\n" .
	                    "New Password: $pass\n\n");
		$smtp->dataend();
		$smtp->quit;
	    }
}