view release on metacpan or  search on metacpan

lib/FAQ/OMatic/Auth.pm  view on Meta::CPAN

	# 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($_=<COOKIEFILE>)) {
		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($_=<IDFILE>)) {
		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($_=<IDFILE>)) {
		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 <torrie@pi.pair.com>: 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...