CGI::Auth - Simple session-based password authentication for CGI applications

    require CGI::Auth;

    my $auth = new CGI::Auth({
        -authdir		=> 'auth',
        -formaction		=> "myscript.pl",
        -authfields		=> [
            {id => 'user', display => 'User Name', hidden => 0, required => 1},
            {id => 'pw', display => 'Password', hidden => 1, required => 1},
        ],
    });
    $auth->check;

    my $auth = new CGI::Auth( \%options );

# $Id: Auth.pm,v 1.17 2004/01/28 07:05:46 cmdrwalrus Exp $

package CGI::Auth;

use strict;

use Carp;

use vars qw/$VERSION/;
$VERSION = '3.00';

# This delimiter cannot be a regex special character, unfortunately, since it 
# is used with split.  So, for instance, the pipe (|) is not allowed, as well 
# as the dash (-), caret (^), dot (.), etc...
use constant DELIMITER => ':';

sub new 
{
	my $proto = shift;
    my $class = ref($proto) || $proto;
	my $self = {};
	bless $self, $class;

	$self->init(@_) or return undef;

	return $self;
}

# Called by new--all parameters to new are passed off to init for processing.
sub init
{
	my ($self, $param) = (shift, shift);

	return 0 unless (UNIVERSAL::isa($param, 'HASH'));

	# Parameters in an anonymous hash.
	# All config options are passed here... no config file!
	$self->{cgi} = $param->{-cgi};
    $self->{sessfile} = $param->{-sessfile};
	$self->{admin} = $param->{-admin} ? 1 : 0;

	$self->{authdir} = $param->{-authdir};
	$self->{sessdir} = $param->{-sessdir};
	for ($self->{authdir}, $self->{sessdir})
	{
		s|/+$|| if ($_);	# Delete trailing slashes.
	}

	$self->{userfile} = $param->{-userfile};
	if ($self->{logintmpl} = $param->{-logintmpl})			    # Either an HTML::Template template, 
    {
 		$self->{logintmplpath} = $param->{-logintmplpath} || [];
    }
    else
	{
		$self->{loginheader} = $param->{-loginheader};			# or a header and footer.
		$self->{loginfooter} = $param->{-loginfooter};
	}
	$self->{formaction} = $param->{-formaction};
	$self->{authfields} = $param->{-authfields};
	$self->{timeout} = $param->{-timeout};
	$self->{cgiprune} = $param->{-cgiprune} ? 1 : 0;
	$self->{validchars} = $param->{-validchars};
	$self->{md5pwd} = $param->{-md5pwd} ? 1 : 0;

	if ($self->{admin})
	{
		&DenyCGI;
	}
	else
	{
		unless ( UNIVERSAL::isa( $self->{cgi}, 'CGI' ) || UNIVERSAL::isa( $self->{cgi}, 'CGI::Simple' ) )
		{
			# Default to CGI if none is given.
			eval { require CGI; };
			if ( $@ )
			{
				# If CGI is not available, try CGI::Simple.
				eval { require CGI::Simple; };
				if ( $@ )
				{
					# If neither is available, there's gonna be trouble!
					croak "CGI::Auth needs CGI or CGI::Simple, but neither is available";
				}
				else
				{
					# Got CGI::Simple, so create an object of it.
					$self->{cgi} = CGI::Simple->new;
				}
			}
			else
			{
				# Got CGI, so create an object of it.
				$self->{cgi} = new CGI;
			}
		}
	}

	unless ($self->{authdir} && ($self->{admin} || $self->{formaction}) && $self->{authfields})
	{
		&carp("Auth::init - Missing required configuration data");
		return 0;
	}

	# Set defaults for optional config entries if not given:
	unless ($self->{logintmpl})
	{
		$self->{loginheader}	= 'login.head'	unless ($self->{loginheader});
		$self->{loginfooter}	= 'login.foot'	unless ($self->{loginfooter});
	}
	$self->{sessdir}		= 'sess'		unless ($self->{sessdir});
	$self->{userfile}		= 'user.dat'	unless ($self->{userfile});
	$self->{timeout}		= 60 * 15		unless ($self->{timeout});
	$self->{validchars}		||= '\w\d -_.';
	if ( -1 != index( $self->{validchars}, DELIMITER ) )
	{
		&carp( "Auth::init - Delimiter character '" . DELIMITER . "' cannot be included in validchars" );
		return 0;
	}

	for (@{$self}{qw/sessdir userfile logintmpl loginheader loginfooter/})
	{
		if ( $_ and not ref and not m{^/} )
		{
			$_ = $self->{authdir} . '/' . $_;
		}
	}

	unless (-f $self->{userfile})
	{
		&carp("Auth::init - User data file doesn't exist");
		return 0;
	}

	for (@{$self->{authfields}})
	{
		if ($_->{id} eq 'sess_file')
		{
			&carp("Auth::init - id 'sess_file' is reserved");
			return 0;
		}
	}

	unless ($self->{authfields}->[0]->{required} and not $self->{authfields}->[0]->{hidden})
	{
		&carp("Auth::init - First auth field must be required and not hidden--rethink your auth configuration");
		return 0;
	}

	# Create authdata hash.
	$self->{authdata} = {};

	return 1;
}

sub check
{
	my ($self) = @_;

	my $session_file = $self->{sessfile} || $self->{cgi}->param('auth_sessfile');

	if ($session_file)
	{
		# Untaint.
		$session_file =~ s/[^0-9A-Za-z\._]+//g;
		$session_file =~ m/([0-9A-Za-z\._]+)/;
		$self->{sess_file} = $session_file = $1;

		my ($field0) = $self->OpenSessionFile;
		if ($field0)
		{
			return $self->setdata($self->GetUserData($field0));
		}
		elsif (defined $field0)
		{
			$self->PrintLoginForm("Your session has expired.  Please log in again.");
			exit(0);
		}
		else
		{
			$self->PrintLoginForm("Could not open session file.  Please log in again.");
			&carp("Auth::check - Could not open session file");
			exit(0);
		}
	}
	elsif (defined $self->{cgi}->param('auth_submit'))
	{
		my $authfield0 = $self->{authfields}->[0];
		my $field0 = $self->{cgi}->param( 'auth_' . $authfield0->{id} );
		my @userdata = $self->GetUserData( $field0 );
		# Make sure GetUserData found the user.
		if ( not @userdata )
		{
			$self->PrintLoginForm( "Authentication failed!  Check login information and try again." );
			&carp( "Auth::check - Invalid '" . $authfield0->{display} . "' field" );
			exit( 0 );
		}

		# Verify required fields in form data with those in @userdata.
		eval { 
			for my $idx ( 1 .. @{ $self->{authfields} } - 1 )
			{
				my $authfield = $self->{authfields}->[$idx];
				if ( $authfield->{required} )
				{
					my $formvalue = $self->{cgi}->param( 'auth_' . $authfield->{id} );
					if ( $authfield->{hidden} )
					{
						# Check against crypted userdata.
						if ( $self->{md5pwd} )
						{
							# MD5 hash.
							if ( MD5Crypt( $formvalue ) ne $userdata[$idx] )
							{
								die "MD5 mismatch on '" . $authfield->{display} . "' field";
							}
						}
						else 
						{
							# Double crypt().
							if ( DoubleCrypt( $formvalue, $userdata[$idx] ) ne $userdata[$idx] )
							{
								die "crypt() mismatch on '" . $authfield->{display} . "' field";
							}
						}
					}
					else
					{
						# Check against uncrypted userdata.
						if ( $userdata[$idx] ne $formvalue )
						{
							die "Mismatch on '" . $authfield->{display} . "' field";
						}
					}
				}
			}
		}; 
		if ( $@ )
		{
			$self->PrintLoginForm( "Authentication failed!  Check login information and try again." );
			&carp( "Auth::check - $@" );
			exit( 0 );
		}
		else
		{
			if ( $self->{sess_file} = $self->CreateSessionFile( $field0 ) )
			{
				return $self->setdata( @userdata );
			}
			else
			{
				$self->PrintLoginForm( "A session file could not be created.  You may not be able to log in at this time." );
				&carp( "Auth::check - Could not create session file" );
				exit( 0 );
			}
		}
	}
	else
	{
		$self->PrintLoginForm;
		exit(0);
	}
}

sub endsession
{
	my $self = shift;

	if (-f $self->{sessdir} . "/" . $self->{sess_file})
	{
		return unlink $self->{sessdir} . "/" . $self->{sess_file};
	}
	else
	{
		return -1;
	}
}

sub setdata
{
	my $self = shift;
	my @data = @_;

	return 0 if (@data != @{$self->{authfields}});

	for (my $idx = 0; $idx < @data; ++$idx)
	{
		next if ($self->{authfields}->[$idx]->{hidden});

		# Store non-hidden data in authdata for program to access.
		$self->{authdata}->{$self->{authfields}->[$idx]->{id}} = $data[$idx];
	}

	return 1;
}

sub data
{
	my $self = shift;
	my $key = shift;

	if ($key eq 'sess_file')
	{
		return $self->{sess_file};
	}

	return $self->{authdata}->{$key};
}

sub sfparam_name
{
	'auth_sessfile';
}

sub sfparam_value
{
	my $self = shift;

	$self->data('sess_file');
}

sub formfield
{
	my $self = shift;
	
	my $name = $self->sfparam_name;
	my $value = $self->sfparam_value;

	return qq(<input type="hidden" name="$name" value="$value">);
}

sub urlfield
{
	my $self = shift;

	my $name = $self->sfparam_name;
	my $value = $self->sfparam_value;

	return qq($name=$value);
}

sub adduser
{
	my $self = shift;

	&DenyCGI;

	my @userdata = @_;
	&croak("Bad user data") if (@userdata != @{$self->{authfields}});

	# Append user to user file.
	open USER, ">> " . $self->{userfile} 
		or return 0;
	for (my $idx = 0; $idx < @userdata; ++$idx)
	{
		my $authfield = $self->{authfields}->[$idx];
		if ( $authfield->{hidden} )
		{
			if ( $self->{md5pwd} )
			{
				$userdata[$idx] = MD5Crypt( $userdata[$idx] );
			}
			else
			{
				if ( length $userdata[$idx] > 16 )
				{
					&croak( "Hidden field '" . $authfield->{display} . "' cannot have length greater than 16 characters when using crypt" );
				}
				# Store encrypted.
				$userdata[$idx] = DoubleCrypt( $userdata[$idx], join '', ('.', '_', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64] );
			}
		}
	}
	print USER join( DELIMITER, @userdata ), "\n";
	close USER;
}

sub listusers
{
	my ($self) = @_;

	&DenyCGI;

	open USER, "< " . $self->{userfile} or return;
	while (<USER>)
	{
		my ($br) = split( DELIMITER, $_, 2 );
		print "$br\n";
	}
	close USER;
}

sub viewuser
{
	my ($self, $field0) = @_;

	&DenyCGI;

	my @userdata = $self->GetUserData($field0);

	if (@userdata == 0)
	{
		print "$field0 does not exist.\n";
		return 0;
	}
	&croak("Bad user data for $field0") if (@userdata != @{$self->{authfields}});

	for (my $idx = 0; $idx < @userdata; ++$idx)
	{
		my $msg = $self->{authfields}->[$idx]->{display};
		$msg .= " (required)" if ($self->{authfields}->[$idx]->{required});
		$msg .= " (hidden)" if ($self->{authfields}->[$idx]->{hidden});
		$msg .= ": " . $userdata[$idx] . "\n";

		print $msg;
	}
}

sub deluser
{
	my ($self, $field0) = @_;

	&DenyCGI;

	$self->viewuser($field0);

	print "\nDelete this user? ";
	my $resp = <STDIN>;

	# If the response begins with a 'y' (or 'Y'), ie. 'yes' or 'y' or 'you better not!'...
	if ( $resp =~ /^[yY]/ )
	{
		open USER, "< " . $self->{userfile} or &croak("Unable to read userfile: $!");
		my @userfile = <USER>;
		close USER;

		open USER, "> " . $self->{userfile} or &croak("Unable to write userfile: $!");
		for (@userfile)
		{
			if (!/^$field0\b/i)
			{
				print USER $_;
			}
		}
		close USER;
		print "\nUser deleted.\n";
	}
	else
	{
		print "\nUser not deleted.\n";
	}
}

sub prune
{
	my $self = shift;

	&DenyCGI unless ( $self->{cgiprune} );

	my $pruned = 0;

	opendir SESSDIR, $self->{sessdir};
	while (my $file = readdir(SESSDIR))
	{
		$file = $self->{sessdir} . '/' . $file;
		next unless (-f $file);

		my $mtime = (stat _)[9];
		my $now = time;
		my $age = $now - $mtime;

		$pruned += unlink $file if ($age > $self->{timeout});
	}
	closedir SESSDIR;

	return $pruned;
}

sub GetUserData
{
	my ($self, $field0) = @_;

	unless ( $field0 ) 
	{
		warn "Field0 not given";
		return;
	}
	unless ( open( USER, "< " . $self->{userfile} ) ) 
	{
		warn "Couldn't open userfile";
		return;
	}

	my @userdata;
	my $fzero = $field0 . DELIMITER;
	while ( <USER> )
	{
		next if ( !/^$fzero/i );

		# Field 0 found--get user data.
		chop;
		@userdata = split( DELIMITER );
		last;
	}
	close USER;
	if ( lc $userdata[0] ne lc $field0 ) 
	{
		warn "Field 0 ($field0) doesn't match (" . join( ', ', @userdata ) . ")";
		return;
	}

	return @userdata;
}

sub PrintLoginForm
{
	my ($self, $msg) = @_;

	print $self->{cgi}->header;

	if ($self->{logintmpl})
	{
		$self->PLF_template($msg);
	}
	else
	{
		$self->PLF_headerfooter($msg);
	}
}

sub PLF_template
{
	my ($self, $msg) = @_;

	require HTML::Template;

	# logintmpl can be one of three things (which are all true values):
    # 1. An HTML::Template object reference,
    # 2. A hash containing parameters for HTML::Template->new, or
    # 3. A filename (then logintmplpath can be the path parameter).
    my $template = $self->{logintmpl};
    unless ( UNIVERSAL::isa( $template, 'HTML::Template' ) )
    {
        $template = new HTML::Template( 
            UNIVERSAL::isa( $template, 'HASH' ) 
            ? %{ $self->{logintmpl} } 
            : ( 
                filename => $template,
                path => $self->{logintmplpath},
            ) 
        );
    }

	# Create parameters for Auth_Fields <TMPL_LOOP>.
	my @fields = ();
	foreach my $authfield (@{$self->{authfields}})
	{
		if ($authfield->{required})
		{
			push @fields, {
				Display_Name => $authfield->{display}, 
				Input_Name => 'auth_' . $authfield->{id}, 
				Input_Type => $authfield->{hidden} ? 'password' : 'text',
			};
		}
	}

	$template->param(
		Message => $msg,
		Auth_Fields => \@fields,
		Button_Name => 'auth_submit',
		Form_Action => $self->{formaction},
		Form_Fields => $self->FormFields,
	);
	print $template->output();
}

sub PLF_headerfooter
{
	my ($self, $msg) = @_;

	if (open HEADER, "< " . $self->{loginheader})
	{
		my @header = <HEADER>;
		close HEADER;
		print @header;
	}
	else
	{
		print <<DEFAULT;
<html>
<head>
<title>Login</title>
</head>
<body>
<p>Please enter your login information:</p>
DEFAULT
	}

	if ($msg)
	{
		print qq(<p style="color: red; font-weight: bold;">$msg</p>\n);
	}

	my $formaction = $self->{formaction};
	print <<START;
<form method=post action="$formaction">
<table border=0>
START

	print $self->FormFields;

	# Print form for filling in auth fields.
	foreach my $authfield (@{$self->{authfields}})
	{
		if ($authfield->{required})
		{
			if ($authfield->{hidden})
			{
				print "<tr><td align=left><p><b>", $authfield->{display}, ":</b></p></td>", 
					"<td align=left><p><input type=password name=auth_", $authfield->{id}, "></p></td>\n";
			}
			else
			{
				print "<tr><td align=left><p><b>", $authfield->{display}, ":</b></p></td>", 
					"<td align=left><p><input type=text name=auth_", $authfield->{id}, "></p></td>\n";
			}
		}
	}

	print <<END;
</table>
<p><input type=submit name="auth_submit" value="Login"></p>
</form>
END

	if (open FOOTER, "< " . $self->{loginfooter})
	{
		my @footer = <FOOTER>;
		close FOOTER;
		print @footer;
	}
	else
	{
		print "</body></html>\n";
	}
}

sub FormFields
{
	my ($self) = shift;

	my $formfields = '';

	for my $name ($self->{cgi}->param)
	{
		next if ($name =~ /^auth_/);
		my @values = $self->{cgi}->param($name);

		if (@values < 2)	# i.e., 0 or 1 values.
		{
			my $val = $values[0] || '';
			$formfields .= qq(<input type=hidden name="$name" value="$val">\n);
		}
		else
		{
			$formfields .= join ("\n",
				qq(<select multiple name="$name" style="display:none">), 
				(map {qq(<option selected value="$_" style="display:none">$_</option>)} @values), 
				qq(</select>), 
				''		# For a \n at the end.
			);
		}
	}

	return $formfields;
}

sub CreateSessionFile
{
	my ($self, $field0) = @_;

	my @chars = (0..9, 'A'..'Z');
	my $sessfilename;

	# Verify format and untaint.
    my $env_ra = $ENV{REMOTE_ADDR} || '';
	$env_ra =~ /([\dA-F\.:]+)/;		# IPv4 or IPv6 address.
	my $remoteaddr = $1 || '';

	do
	{
		$sessfilename = join '', map {$chars[rand 36]} (1..12);
	} while (-e $self->{sessdir} . "/$sessfilename");

	open SESS, "> " . $self->{sessdir} . "/$sessfilename" 
		or return;
	print SESS $field0, "\n";
	print SESS $remoteaddr, "\n" if ( $remoteaddr );
	close SESS;
	
	return $sessfilename;
}

sub OpenSessionFile
{
	my $self = shift;

	my $sessfile = $self->{sessdir} . "/" . $self->{sess_file};
	if (-f $sessfile)
	{
		my $mtime = (stat _)[9];
		my $now = time;
		my $age = $now - $mtime;		# How old is the session file?

		# Check age against timeout value.
		if ($age > $self->{timeout})
		{
			# Too old!
			unlink $sessfile;
			return 0;
		}

		# Attempt to open file.
		if (open (SESS, "< $sessfile"))
		{
			# Read information from file.
			my $field0 = <SESS>;
			my $file_ra = <SESS>;
			close SESS;

			# If $field0 has any invalid chars, return error.
			# This also untaints $field0.
			my $validchars = $self->{validchars};
			if ( $field0 =~ /^([$validchars]+)$/ )
			{
				$field0 = $1;
			}
			else
			{
				warn "UserID [$field0] found in session file is invalid";
				return undef;
			}

			$file_ra =~ /^(\S*?)$/;
			$file_ra = $1;
			# Verify remote IP address, if present in file.
			# What this does is ensure that if the REMOTE_ADDR was available at 
			# login time, it must be available now and must be the same.
			if ( $file_ra and $file_ra ne $ENV{REMOTE_ADDR} )
			{
				# IP address doesn't match.
				# Return error: unable to access session file.
				warn "Address [$file_ra] found in session file does not match REMOTE_ADDR [" . $ENV{REMOTE_ADDR} . "]";
				return undef;
			}

			# Update modification time for timeout.
			utime $now, $now, $sessfile;

			# Return Field 0 (ie, user name).
			return $field0;
		}

		# File couldn't be opened.
		&carp("Couldn't open session file $sessfile because '$!'");
	}

	# Non-existent or inaccessible session file.
	return undef;
}

sub DenyCGI
{
	if ( $ENV{GATEWAY_INTERFACE} || $ENV{REQUEST_METHOD} || $ENV{REMOTE_ADDR} )
	{
		print <<ERRORDOC;
Content-type: text/html

<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<html><head><title>Forbidden</title></head>
<body><h1>Access Denied</h1><p>You are not allowed to access this page.</p></body>
</html>
ERRORDOC
		exit;
	}
}

sub DoubleCrypt
{
	my ($str, $salt) = @_;

	# Eliminates warnings about substr beyond end of string.
	if (length($str) > 8)
	{
		return crypt(substr($str, 0, 8), $salt) . crypt(substr($str, 8, 8), $salt);
	}
	else
	{
		return crypt($str, $salt) . crypt('', $salt);
	}
}

sub MD5Crypt
{
	my ( $str ) = @_;

	require Digest::MD5;
	return Digest::MD5->new->add( $str )->b64digest;
}

# Return true when 'require'd.
1;