File Coverage

blib/lib/FAQ/OMatic/Auth.pm

Criterion	Covered	Total	%
statement	27	206	13.1
branch	0	90	0.0
condition	0	79	0.0
subroutine	9	23	39.1
pod	0	14	0.0
total	36	412	8.7

##############################################################################
# The Faq-O-Matic is Copyright 1997 by Jon Howell, all rights reserved.      #
#                                                                            #
# 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.#
#                                                                            #
# Jon Howell can be contacted at:                                            #
# 6211 Sudikoff Lab, Dartmouth College                                       #
# Hanover, NH  03755-3510                                                    #
# [e-mail]                                                      #
#                                                                            #
# An electronic copy of the GPL is available at:                             #
# http://www.gnu.org/copyleft/gpl.html                                       #
#                                                                            #
##############################################################################

use strict;

###
### The FaqAuth module provides identification, authentication,
### and authorization services for the Faq-O-Matic.
###
### Custom authentication schemes should
### be implemented by using the hooks in this module. (For
### now there are no hooks, but in theory there should be one
### replaceable function.) You'd rather not modify this file,
### so you can be drop-in compatible with future faqomatic
### releases.
###

package FAQ::OMatic::Auth;

use FAQ::OMatic;
use FAQ::OMatic::Item;
use FAQ::OMatic::AuthLocal;
use FAQ::OMatic::Groups;
use FAQ::OMatic::I18N;
use FAQ::OMatic::Entropy;
use Digest::MD5 qw(md5_hex);

# a global constant (accessible outside using my namespace)
use vars qw($cookieExtra);	# constant, visible to maintenance.pm

my $trustedID = undef;
						# Perm values only:
						# '7','9' -- returned by perm routines to indicate
						#		authQuality must be 5, and user must be the
						#		moderator of the item.
						# '6' -- a perm that indicates a group membership
						#		requirement. (actually "6 group_name".)
						# $authQuality's and Perm* values:
						# '5' -- user has provided proof that ID is correct
						# '3' -- user has merely claimed this ID
						# '1' -- no ID is offered

$cookieExtra = 600;		# 10 extra minutes to submit forms after filling
						# them out so you don't have to worry about
						# losing your text.

sub getID {
	my $params = FAQ::OMatic::getParams();	# get cached params

	my $trustedID = FAQ::OMatic::getLocal('trustedID');
	my $authQuality = FAQ::OMatic::getLocal('authQuality');
	if (not defined $trustedID) {
		if (defined $params->{'auth'}) {
			# use a user-overridable auth function
			($trustedID,$authQuality) = authenticate($params);
		} elsif (defined $params->{'id'}) {
			# id without authorization
			$trustedID = $params->{'id'};
			$authQuality = 3;
		} else {
			# no authorization offered
			$trustedID = 'anonymous';
			$authQuality = 1;
		}
	}

	FAQ::OMatic::setLocal('trustedID', $trustedID);
	FAQ::OMatic::setLocal('authQuality', $authQuality);
	return ($trustedID,$authQuality);
}

# result is 'false' if user CAN edit the part, else an error message
sub checkPerm {
	my $item = shift;
	my $operation = shift;

	my ($id,$aq) = getID();

	my $whocan = getInheritedProperty($item, $operation);

	# if just some low quality of authentication is required, prove
	# user has provided it:
	$whocan =~ m/^(\d+)/;
	my $whocanNum = $1 || 7;
		# THANKS to Mikel Smith
		# for pointing out that this code was generating warning messages
	if ($whocanNum <= 5 and $whocanNum <= $aq) {
		# users' ID dominates required ID
		return 0;
	}

	# prove user belongs to required group:
	if ($whocanNum == 6
		and FAQ::OMatic::Groups::checkMembership($whocan, $id)) {
		# user belongs to the specified group
		return 0;
	}

	# prove user has at least moderator priveleges
	if ((($whocanNum==7) and ($aq==5))
		and (($id eq getInheritedProperty($item, 'Moderator'))
			 or ($id eq $FAQ::OMatic::Config::adminAuth)
			 or ('anybody' eq getInheritedProperty($item, 'Moderator'))
			)
		) {
		# user has proven authentication, and is the moderator of the item
		return 0;
	}

	return $whocan;
}

sub getInheritedProperty {
	my $item = shift;
	my $property = shift;
	my $depth = shift || 0;

	if (isPropertyGlobal($property)) {
		# save a recursive walk up the tree -- this property
		# is defined at the top.
		# THANKS to John Goerzen  for
		# finding a dumb bug here.
		$item = new FAQ::OMatic::Item('1');
	}
	if (not ref $item) {
		# get property from top item if no item specified
		$item = new FAQ::OMatic::Item('1');
	}

	if (defined($item) and defined $item->{$property}) {
		return wantarray()
			? ($item->{$property}, $item)
			: $item->{$property};
	}

	if (not defined($item)
		or ($item eq '')
		or ($item->getParent() eq $item)
		or ($depth > 80)) {

		# no-one defines it, all the way up the chain
		return wantarray()
			? (getDefaultProperty($property), undef)
			: getDefaultProperty($property);
	} else {
		return getInheritedProperty($item->getParent(), $property, $depth+1);
	}
}

# fields: [ default value, isGlobal ]
my %defaultProperties = (
	'Moderator' => 			[ 'nobody', 0 ],
	'MailModerator' => 		[ 0, 0 ],
       	'Notifier' =>			[ 'nobody', 0 ],
	'MailNotifier' =>		[ 0, 0 ],
	'PermEditPart' =>		[ 5, 0 ],		# users with proven authentication
	'PermAddPart' =>		[ 5, 0 ],
	'PermAddItem' =>		[ 5, 0 ],
#	'PermEditItem' =>		[ 5, 0 ],		# (deprecated)
	'PermEditTitle' =>		[ 5, 0 ],		# moderator
	'PermEditDirectory' =>	[ 7, 0 ],
	'PermModOptions' =>		[ 7, 0 ],
	'PermUseHTML' =>		[ 7, 0 ],
	'PermNewBag' =>			[ 7, 1 ],
	'PermReplaceBag' =>		[ 7, 1 ],
	'PermInstall' =>		[ 7, 1 ],
	'PermEditGroups' =>		[ 7, 1 ],
	'RelaxChildPerms' =>	[ 'norelax', 0],
);

sub getDefaultProperty {
	my $property = shift;

	my $result = $defaultProperties{$property};
	if (not defined $result) {
		$result = 7;
		FAQ::OMatic::gripe('panic',
			"Property $property expected but not defined");	# tell author
	}
	return $result->[0];
}

sub isPropertyGlobal {
	my $property = shift;

	my $result = $defaultProperties{$property};
	return $result->[1] || 0;
}

# ensurePerm()
# Checks permissions, returns '' if okay, else returns a redirect to
# authenticate.
# In list context, returns the same value followed by a quality
# value, so if you require two ensurePerms, you return the redirect
# with the higher qualityf value (so the user gets all the authentication
# done at once). See submitMove.
sub ensurePerm {
	my @p = @_;

	my (
		$item,
		$operation,
		$restart,			# which program to run to restart operation
							# after user presents ID
		$cgi,
		$extraTime,			# allow slightly stale cookies, so that a
							# cookie isn't likely to time out between
							# clicking "edit" and "submit", which annoys.
		$xreason,			# an extra reason, needed to distinguish
							# two cases (modOptions) in editItem.
		$failexit			# redirect and exit on failure
	) = FAQ::OMatic::rearrange(
		['item','operation','restart','cgi','extraTime','xreason',
			'failexit'],
		@p);
	$item ||= '';

	my $result = '';

	my $cookieActual = $FAQ::OMatic::Config::cookieLife || 3600;
	$cookieActual += $cookieExtra if ($extraTime);
	FAQ::OMatic::setLocal('cookieActual', $cookieActual);

	my $authFailed = checkPerm($item,$operation);

	if ($authFailed) {
		my $url = FAQ::OMatic::makeAref('authenticate',
			{'_restart' => $restart, '_reason'=>$authFailed,
			 '_xreason'=>($xreason||'')}, 'url', 'saveTransients');
		$result = FAQ::OMatic::redirect($cgi, $url, 'asString');
		if ($failexit||'') {
			FAQ::OMatic::redirect($cgi, $result);
		}
	}

	return wantarray	? ($result, $authFailed)
						: $result;
}

sub newCookie {
	my $id = shift;

	# Use an existing cookie if available. (why is this good? Just
	# to keep the cookies file slimmer?)
	my ($cookie,$cid,$ctime);
	($cookie,$cid,$ctime) = findCookie($id,'id');
	return $cookie if (defined $cookie);

	$cookie = "ck".FAQ::OMatic::Entropy::gatherRandomString();

	my $cookiesFile = "$FAQ::OMatic::Config::metaDir/cookies";
	open COOKIEFILE, ">>$cookiesFile";
	print COOKIEFILE "$cookie $id ".time()."\n";
	close COOKIEFILE;
	if (not chmod(0600, "$cookiesFile")) {
		FAQ::OMatic::gripe('problem', "chmod failed on $cookiesFile");
	}

	return $cookie;
}

sub findCookie {
	my $match = shift;
	my $by = shift;

	my ($cookie,$cid,$ctime);
	if (not open COOKIEFILE, "<$FAQ::OMatic::Config::metaDir/cookies") {
		return undef;
	}
	while (defined($_=)) {
		chomp;
		($cookie,$cid,$ctime) = split(' ');

		# ignore dead cookies
		my $cookieActual = FAQ::OMatic::getLocal('cookieActual')
				|| $FAQ::OMatic::Config::cookieLife
				|| 3600;
		next if ((time() - $ctime) > $cookieActual);

		if (($by eq 'id') and ($cid eq $match)) {
			close COOKIEFILE;
			return ($cookie,$cid,$ctime);
		}
		if (($by eq 'cookie') and ($cookie eq $match)) {
			close COOKIEFILE;
			return ($cookie,$cid,$ctime);
		}
	}
	close COOKIEFILE;
	return undef;
}

# these functions manipulate a file that maps IDs to
# (ID,password,...) tuples. (... = future expansion)
# Right now it's a flat file, but maybe someday it should be a
# dbm file if anyone ever has zillions of authorized posters.

# given an ($id,$password,...) array, writes it into idfile
sub writeIDfile {
	my ($id,$password,@rest) = @_;

	my $lockf = FAQ::OMatic::lockFile("idfile");
	FAQ::OMatic::gripe('error', "idfile is locked.") if (not $lockf);

	if (not open(IDFILE, "<$FAQ::OMatic::Config::metaDir/idfile")) {
		FAQ::OMatic::unlockFile($lockf);
		FAQ::OMatic::gripe('abort', "FAQ::OMatic::Auth::writeIDfile: Couldn't "
				."read $FAQ::OMatic::Config::metaDir/idfile because $!");
		return;
	}

	# read id mappings in
	my %idmap;
	my ($idf,$passf,@restf);
	while (defined($_=)) {
		chomp;
		($idf,$passf,@restf) = split(' ');
		$idmap{$idf} = $_;
	}
	close IDFILE;

	# change the mapping for id
	$idmap{$id} = join(' ', $id, $password, @rest);

	# write id mappings.
	if (not open(IDFILE, ">$FAQ::OMatic::Config::metaDir/idfile-new")) {
		FAQ::OMatic::unlockFile($lockf);
		FAQ::OMatic::gripe('abort', "FAQ::OMatic::Auth::writeIDfile: Couldn't "
				."write $FAQ::OMatic::Config::metaDir/idfile-new because $!");
		return;
	}

	foreach $idf (sort keys %idmap) {
		print IDFILE $idmap{$idf}."\n";
	}
	close IDFILE;

	unlink("$FAQ::OMatic::Config::metaDir/idfile") or
		FAQ::OMatic::gripe('abort', "FAQ::OMatic::Auth::writeIDfile: Couldn't "
				."unlink $FAQ::OMatic::Config::metaDir/idfile because $!");
	rename("$FAQ::OMatic::Config::metaDir/idfile-new", "$FAQ::OMatic::Config::metaDir/idfile") or
		FAQ::OMatic::gripe('abort', "FAQ::OMatic::Auth::writeIDfile: Couldn't "
				."rename $FAQ::OMatic::Config::metaDir/idfile-new to idfile because $!");
	chmod 0600, "$FAQ::OMatic::Config::metaDir/idfile" or
		FAQ::OMatic::gripe('problem', "FAQ::OMatic::Auth::writeIDfile: Couldn't "
				."chmod $FAQ::OMatic::Config::metaDir/idfile because $!");

	FAQ::OMatic::unlockFile($lockf);
}

# given an id, returns an array starting ($id,$password,...)
sub readIDfile {
	my $id = shift || '';	# key to lookup on
	my $dontHideVersion = shift || '';
						# keep regular lookups from seeing version number
						# record. (smacks of a hack, but this is Perl!)

	return undef if (($id eq 'version') and (not $dontHideVersion));

	my $lockf = FAQ::OMatic::lockFile("idfile");
	FAQ::OMatic::gripe('error', "idfile is locked.") if (not $lockf);

	if (not open(IDFILE, "<$FAQ::OMatic::Config::metaDir/idfile")) {
		FAQ::OMatic::unlockFile($lockf);
		FAQ::OMatic::gripe('abort', "FAQ::OMatic::Auth::readIDfile: Couldn't "
				."read $FAQ::OMatic::Config::metaDir/idfile because $!");
		return undef;
	}

	my ($idf,$passf,@restf);
	while (defined($_=)) {
		chomp;
		($idf,$passf,@restf) = split(' ');
		last if ($idf eq $id);
	}
	close IDFILE;

	FAQ::OMatic::unlockFile($lockf);

	if (defined($idf) and ($idf eq $id)) {
		return ($idf,$passf,@restf);
	}

	return undef;
}

sub checkCryptPass {
	my ($cleartext, $crypted) = @_;
	if ($crypted =~ m/md5\((\S+),(\S+)\)/) {
		# if this record was encoded with the new md5 encoding, then
		# it'll contain a big salt and then the result:
		my $salt = $1;
		my $cryptedResult = $2;
		my $attemptedCrypt = md5_hex($salt, $cleartext);
		return ($attemptedCrypt eq $cryptedResult);
	} else {
		# compatibility mode: use crypt()
		# We no longer generate passwords with crypt, but we
		# allow checking against crypt()ed passwords to avoid
		# annoying users with a password-reset demand.
		#my $salt = substr($crypted, 0, 2);
		# specific fix from Evan Torrie : most crypt()s
		# don't care of there's excess salt, and those with MD5 crypts use
		# more than the first two bytes as salt.
		my $salt = $crypted;
		return (crypt($cleartext, $salt) eq $crypted);
	}
}

sub cryptPass {
	my $pass = shift;
	my $salt = FAQ::OMatic::Entropy::gatherRandomString();
	return "md5(".$salt.",".md5_hex($salt.$pass).")";
}

sub authenticate {
	my $params = shift;

	my $auth = $params->{'auth'};

	# if there's a cookie...
	if ($auth =~ m/^ck/) {
		my ($cookie,$cid,$ctime) = findCookie($auth,'cookie');
		# and it's good, then return the implied id
		return ($cid,5) if (defined $cid);
		# if it's bad, fall through and inherit anonymous auth
	}

	# if we authenticate...
	if (($params->{'auth'}||'') eq 'pass' or
		((($params->{'_none_id'}||'') eq '')
			and (($params->{'_pass_id'}||'') ne ''))) {
		my $id = $params->{'_pass_id'};
		my $pass = $params->{'_pass_pass'};
		if (FAQ::OMatic::AuthLocal::checkPassword($id, $pass)) {
			# set up a cookie to use for a shortcut later,
			# and return the authentication pair
			$params->{'auth'} = newCookie($id);
			return ($id,5);
		} else {
			# let authenticate know to report the bad password
			$params->{'badPass'} = 1;
			# remove the password from the parameters, since
			# we don't want it ending up in a later GET request
			# (and then in server logs). (It got here by a POST
			# from the password form.)
			$params->{'_pass_id'} = '';
			$params->{'_pass_pass'} = '';
			# fall through to inherit some crummier Authentication Quality
		}
	}

	if (($params->{'auth'} eq 'none')
		and (defined $params->{'_none_id'})) {
		# move id where we can pass it around
		$params->{'id'} = $params->{'_none_id'};
	}

	# default authentication: whatever id we can come up with,
	# but quality is at most 3
	my $id = $params->{'id'} || 'anonymous';
	my $aq = $params->{'id'} ? 3 : 1;
	return ($id, $aq);
}

sub authError {
	my $reason = shift;
	my $file = shift;

	my %staticErrors = (
		9 => gettext("the administrator of this Faq-O-Matic"),
		5 => gettext("someone who has proven their identification"),
		3 => gettext("someone who has offered identification"),
		1 => gettext("anybody") );

	return $staticErrors{$reason} if ($staticErrors{$reason});

	if ($reason eq '7') {
		my $modname = '';
		if (defined($file)
			&& ($file ne '')) {
			# THANKS "Alan J. Flavell"
			# for fixing a "Use of uninitialized value" here.
			my $item = new FAQ::OMatic::Item($file);
			$modname = " (".getInheritedProperty($item, 'Moderator').")";
		}
		return gettext("the moderator of the item").$modname;
	}

	if ($reason =~ m/^6/) {
		return gettexta("%0 group members",FAQ::OMatic::Groups::groupCodeToName($reason));
	}

	return "I don't know who";
}

1;