captcha.pl

#!/usr/bin/perl

use CGI::Carp qw(fatalsToBrowser);

use strict;

use CGI;
use DBI;

use lib '.';
BEGIN { use File::Basename;
	my $dirname = dirname(__FILE__);
	chdir($dirname);
	require "$dirname/config.pl";
	require "$dirname/config_defaults.pl";
	require "$dirname/strings_en.pl";
	require "$dirname/wakautils.pl";
}



return 1 if(caller);

my $font_height=8;
my %font=(
	a=>[4,[0,2,1,1,2,1,3,2,3,5,4,6],[3,3,1,3,0,4,0,5,1,6,2,6,3,5]],
	b=>[3,[0,0,0,6,2,6,3,5,3,4,2,3,0,3]],
	c=>[3,[3,6,1,6,0,5,0,4,1,3,3,3]],
	d=>[3,[3,0,3,6,1,6,0,5,0,4,1,3,3,3]],
	e=>[3,[3,6,1,6,0,5,0,3,1,2,3,2,3,3,2,4,0,4]],
	f=>[3,[1,6,1,1,2,0,3,0],[0,3,2,3]],
	g=>[3,[3,6,1,6,0,5,0,4,1,3,3,3,3,7,2,8,0,8]],
	h=>[3,[0,0,0,6],[0,3,2,3,3,4,3,6]],
	i=>[2,[1,3,1,6],[1,1,1.5,1.5,1,2,0.5,1.5]],
	j=>[3,[2,3,2,7,1,8,0,7],[2,1,2.5,1.5,2,2,1.5,1.5]],
	k=>[3,[0,0,0,6],[0,4,1,4,2,2],[0,4,1,4,3,6]],
	l=>[2,[0.5,0,0.5,5,1.5,6]],
	m=>[4,[0,6,0,3,1,3,2,4],[2,6,2,3,3,3,4,4,4,6]],
	n=>[3,[0,3,0,6],[0,4,1,3,2,3,3,4,3,6]],
	o=>[3,[0,4,1,3,2,3,3,4,3,5,2,6,1,6,0,5,0,4]],
	p=>[3,[0,8,0,3,2,3,3,4,3,5,2,6,0,6]],
	q=>[3,[3,6,1,6,0,5,0,4,1,3,3,3,3,8],[2,7,4,7]],
	r=>[3,[0,3,0,6],[0,4,1,3,2,3]],
	s=>[3,[0,6,2,6,3,5,0,4,1,3,3,3]],
	t=>[3,[1,1,1,5,2,6],[0,3,2,3]],
	u=>[3,[0,3,0,6,2,6,3,5,3,3]],
	v=>[3,[0,3,1.5,6,3,3]],
	w=>[4,[0,3,0,5,1,6,2,5,3,6,4,5,4,3]],
	x=>[3,[0,3,3,6],[0,6,3,3]],
	y=>[3,[0,3,0,5,1,6,3,6],[3,3,3,7,2,8,0,8]],
	z=>[3,[0,3,3,3,0,6,3,6],[0.5,4.5,2.5,4.5]],
	' '=>[3],
);


my $query=new CGI;
my $key=($query->param("key") or 'default');
my $selector=($query->param("selector") or ".captcha");
my $style=($query->cookie("wakabastyle") or DEFAULT_STYLE);

my @foreground=find_stylesheet_color($style,$selector);
my @background=(0xff,0xff,0xff);



my $dbh=DBI->connect(SQL_DBI_SOURCE,SQL_USERNAME,SQL_PASSWORD,{AutoCommit=>1}) or die S_SQLCONF;
$dbh->{'mysql_enable_utf8'} = 1;

$dbh->do('SET NAMES utf8');
init_captcha_database($dbh) unless(table_exists_captcha($dbh,SQL_CAPTCHA_TABLE));

my $ip=($ENV{HTTP_CF_CONNECTING_IP} or '0.0.0.0');
my ($word,$timestamp)=get_captcha_word($dbh,$ip,$key);

if(!$word)
{
	$word=make_word();
	$timestamp=time();
	save_captcha_word($dbh,$ip,$key,$word,$timestamp);
}

srand $timestamp;



print $query->header(
	-type=>'image/gif',
#	-expires=>'+'.($timestamp+(CAPTCHA_LIFETIME)-time()),
#	-expires=>'now',
);

binmode STDOUT;

make_image($word);

#
# End of main code
#



#
# Code generation
#

sub make_word()
{
	my %grammar=(
		W => ["%C%%T%","%C%%T%","%C%%X%","%C%%D%%F%","%C%%V%%F%%T%","%C%%D%%F%%U%","%C%%T%%U%","%I%%T%","%I%%C%%T%","%A%"],
		A => ["%K%%V%%K%%V%tion"],
		K => ["b","c","d","f","g","j","l","m","n","p","qu","r","s","t","v","s%P%"],
		I => ["ex","in","un","re","de"],
		T => ["%V%%F%","%V%%E%e"],
		U => ["er","ish","ly","en","ing","ness","ment","able","ive"],
		C => ["b","c","ch","d","f","g","h","j","k","l","m","n","p","qu","r","s","sh","t","th","v","w","y","s%P%","%R%r","%L%l"],
		E => ["b","c","ch","d","f","g","dg","l","m","n","p","r","s","t","th","v","z"],
		F => ["b","tch","d","ff","g","gh","ck","ll","m","n","n","ng","p","r","ss","sh","t","tt","th","x","y","zz","r%R%","s%P%","l%L%"],
		P => ["p","t","k","c"],
		Q => ["b","d","g"],
		L => ["b","f","k","p","s"],
		R => ["%P%","%Q%","f","th","sh"],
		V => ["a","e","i","o","u"],
		D => ["aw","ei","ow","ou","ie","ea","ai","oy"],
		X => ["e","i","o","aw","ow","oy"]
	);

	return cfg_expand("%W%",%grammar);
}

sub get_captcha_key($)
{
	my ($parent)=@_;

	return 'res'.$parent if($parent);
	return 'mainpage';
}



#
# Finding and saving words
#

sub get_captcha_word($$$)
{
	my ($dbh,$ip,$key)=@_;
	my ($sth,$row);

	$sth=$dbh->prepare("SELECT word,timestamp FROM ".SQL_CAPTCHA_TABLE." WHERE ip=? AND pagekey=?;") or return undef;
	$sth->execute($ip,$key) or return undef; # the captcha script creates the database, so it might not exist yet
	return @{$row} if($row=$sth->fetchrow_arrayref());

	return undef;
}

sub save_captcha_word($$$$$)
{
	my ($dbh,$ip,$key,$word,$time)=@_;

	delete_captcha_word($dbh,$ip,$key);

	my $sth=$dbh->prepare("INSERT INTO ".SQL_CAPTCHA_TABLE." VALUES(?,?,?,?);") or die S_SQLFAIL;
	$sth->execute($ip,$key,$word,$time) or die S_SQLFAIL;

	trim_captcha_database($dbh); # only cleans up on create - good idea or not?
}

sub check_captcha($$$$)
{
	my ($dbh,$captcha,$ip,$parent)=@_;

	my $key=get_captcha_key($parent);
	my ($word)=get_captcha_word($dbh,$ip,$key);

	make_error(S_NOCAPTCHA) unless($word);
	make_error(S_BADCAPTCHA) if($word ne lc($captcha));

	delete_captcha_word($dbh,$ip,$key); # should the captcha word be deleted on an UNSUCCESSFUL try, too, maybe?
}

sub delete_captcha_word($$$)
{
	my ($dbh,$ip,$key)=@_;

	my $sth=$dbh->prepare("DELETE FROM ".SQL_CAPTCHA_TABLE." WHERE ip=? AND pagekey=?;") or return;
	$sth->execute($ip,$key) or return;
}

#
# Recaptcha
#

sub check_recaptcha {
	my($response,$ip,$preval) = @_;
	
	eval "use Captcha::reCAPTCHA";
	die "In check_recaptcha, an error occured: $@" if($@);
	
	make_error('You must enter a CAPTCHA.',$preval) unless $response;

	my $c=Captcha::reCAPTCHA->new;
	my $result=$c->check_answer_v2(RECAPTCHA_PRIVATE_KEY,$response,$ip);
	# die "In check_recaptcha, result: ".Dumper(\$result);
	
	return $result if $preval == 1 && $result->{is_valid};
	
	make_error(S_BADCAPTCHA,$preval) unless $result->{is_valid};
}

sub prevalidate_captcha {
	my ($dbh,$response,$parent,$data) = @_;
	my ($result,$sth,$row,$i,$dupe,$time,$ip,@newsessions);
	$ip = get_ip(USE_CLOUDFLARE);
	$time = time();
	our @sessions;
	
	# check if ip already has an open session and remove expired sessions
	if(USE_FASTCGI == 1) {
		foreach my $session (@sessions) {
			if($session->{created} + PREVAL_KEY_LIFETIME > $time) {
				push @newsessions, $session;
				$dupe = 1 if $session->{ip} eq $ip
			}
		}
		
		@sessions = @newsessions;
	}
	else {
		my (@delete,$delete);
		$sth = $dbh->prepare("SELECT * FROM " . SQL_SESSION_TABLE . ";") or make_error(S_SQLFAIL,$data);
		$sth->execute() or make_error(S_SQLFAIL,$data);
		
		while($row = $sth->fetchrow_hashref()) {
			if($$row{timestamp} + PREVAL_KEY_LIFETIME < $time) {
				push @delete, $$row{num};
			}
			else {
				$dupe = 1 if $$row{ip} eq $ip;
			}
		}
		
		if($delete[0]) {
			$delete = join(',',@delete);
			$sth = $dbh->prepare("DELETE FROM ".SQL_SESSION_TABLE." WHERE num IN ($delete);") or make_error(S_SQLFAIL,$data);
			$sth->execute() if ($delete =~ /[0-9\,]/) or make_error(S_SQLFAIL,$data) # just in case
		}
	}
	
	# as long as data is undefined otherwise this should return json only when the request is json
	make_error('You can only have one active key. Please wait up to ' . PREVAL_KEY_LIFETIME . ' seconds before posting again.' ,$data) if $dupe;
	
	if($data) {
		$result = check_recaptcha($data->{response},$ip,1);
		
		if($result->{is_valid}) {
			my $session = make_session($dbh,$data->{response},$data->{parent},$ip,$time,1);
			
			make_json_header();
			print encode_string(PREVAL_RESPONSE_TEMPLATE->(
				key => $session->{key}
			));
		}
	}
	else {
		$result = check_recaptcha($response,$ip,1);
			
		if($result->{is_valid}) {
			my $session = make_session($dbh,$response,$parent,$ip,$time);
			
			make_cookies(
				wakapreval=>$session->{key},
				-charset => CHARSET,
				-autopath => COOKIE_PATH,
				-expires => $time + PREVAL_KEY_LIFETIME
			);
			
			make_http_forward(HTML_SELF,ALTERNATE_REDIRECT);
		}
		else {
			make_error(S_BADCAPTCHA);
		}
	}
}

sub make_session {
	my ($dbh,$response,$parent,$ip,$time,$json) = @_;
	my ($sth,$row);
	my $key = crypt_password($ENV{HTTP_USER_AGENT}.$response,$parent,$ip,$time);
	our @sessions;
	
	# we could use a users comment, name, etc for validation but it probably wouldn't make a difference in abuse
	my $session = {
		key => $key,
		parent => $parent,
		ip => $ip,
		ua => $ENV{HTTP_USER_AGENT},
		created => $time
	};
	
	if(USE_FASTCGI == 1) {
		push @sessions, $session;
	}
	else {
		$sth = $dbh->prepare("INSERT INTO ".SQL_SESSION_TABLE." VALUES(NULL,?,?,?,?,?);") or make_error(S_SQLFAIL,$json);
		$sth->execute($key,$parent,$ip,$ENV{HTTP_USER_AGENT},$time) or make_error(S_SQLFAIL,$json);
	}
	
	return $session;
}

sub check_key {
	my ($dbh,$key,$parent,$time,$ip,$ua,$json) = @_;
	my ($i,$sth,$row,$valid,@newsessions);
	our @sessions;
	
	if(USE_FASTCGI == 1) {		
		# this could probably be done more perlishly with grep but whatever
		foreach my $session (@sessions) {
			if($key eq $sessions[0]->{key} and 
			$parent eq $sessions[0]->{parent} and 
			$ua eq $sessions[0]->{ua} and
			$ip eq $sessions[0]->{ip}) {
				$valid = 1;
			}
			else {
				push @newsessions,$session unless $session->{created} + PREVAL_KEY_LIFETIME < $time;
			}
		}
		
		@sessions = @newsessions;
		return $valid;
	}
	else {
		my (@delete,$delete);
		$sth = $dbh->prepare("SELECT * FROM ".SQL_SESSION_TABLE.";") or make_error(S_SQLFAIL,$json);
		$sth->execute() or make_error(S_SQLFAIL,$json);
		
		while($row = $sth->fetchrow_hashref()) {
			push @delete, $$row{num} if $$row{timestamp} + PREVAL_KEY_LIFETIME < $time;
			
			$parent = 0 unless $parent;
			$$row{parent} = 0 unless $$row{parent};
			
			if($key eq $$row{sessionkey} and 
			$parent == $$row{parent} and 
			$ua eq $$row{ua} and
			$ip eq $$row{ip}) {
				push @delete, $$row{num};
				$valid = 1;
				last;
			}
		}
		
		if($delete[0]) {
			$delete = join(',', @delete);
			$sth = $dbh->prepare("DELETE FROM ".SQL_SESSION_TABLE." WHERE num IN ($delete);")  or make_error(S_SQLFAIL,$json);
			$sth->execute() or make_error(S_SQLFAIL,$json) if $delete =~ /[0-9\,]/; # just in case
		}
		
		return $valid;
	}
	
	return 0;
}



#
# Database utils
#

sub init_captcha_database($)
{
	my ($dbh)=@_;
	my ($sth);

	$sth=$dbh->do("DROP TABLE ".SQL_CAPTCHA_TABLE.";") if(table_exists_captcha($dbh,SQL_CAPTCHA_TABLE));
	$sth=$dbh->prepare("CREATE TABLE ".SQL_CAPTCHA_TABLE." (".
	"ip TEXT,".
	"pagekey TEXT,".
	"word TEXT,".
	"timestamp INTEGER".
#	",PRIMARY KEY(ip,key)".
	");") or die S_SQLFAIL;
	$sth->execute() or die S_SQLFAIL;
}

sub trim_captcha_database($)
{
	my ($dbh)=@_;
	my $mintime=time()-(CAPTCHA_LIFETIME);

	my $sth=$dbh->prepare("DELETE FROM ".SQL_CAPTCHA_TABLE." WHERE timestamp<=$mintime;") or die S_SQLFAIL;
	$sth->execute() or die S_SQLFAIL;
}

sub table_exists_captcha($$)
{
	my ($dbh,$table)=@_;
	my ($sth);

	return 0 unless($sth=$dbh->prepare("SELECT * FROM ".$table." LIMIT 1;"));
	return 0 unless($sth->execute());
	return 1;
}



#
# Stylesheet functions
#

sub find_stylesheet_color($$)
{
	my ($style,$selector)=@_;

	my ($sheet)=grep
	{
		my ($title)=m!([^/]+)\.css$!i;
		$title=ucfirst $title;
		$title=~s/_/ /g;
		$title=~s/ ([a-z])/ \u$1/g;
		$title=~s/([a-z])([A-Z])/$1 $2/g;
		$title eq $style;
	} glob(CSS_DIR."*.css");
	return (128,0,0) unless($sheet);

	my $contents;
	open STYLESHEET,$sheet or return (128,0,0);
	$contents.=$_ while(<STYLESHEET>);
	close STYLESHEET;

	if($contents=~/(?:}|^)\s+\Q$selector\E\s*{[^}]*color:\s*([^;}]+?)\s*(?:;|}|^)/s)
	{
		my $color=$1;
		if($color=~/#([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})/i)
		{
			return (hex($1),hex($2),hex($3));
		}
		elsif($color=~/#([0-9a-f])([0-9a-f])([0-9a-f])/i)
		{
			return (hex($1x2),hex($2x2),hex($3x2));
		}
		elsif($color=~/rgb\s*\(\s*([0-9]+)\s*,\s*([0-9]+)\s*,\s*([0-9]+)\s*\)/)
		{
			return ($1,$2,$3);
		}
	}
	return (128,0,0);
}



#
# Draw the actual image
#

my (@pixels,$pixel_w,$pixel_h);

sub make_image($)
{
	my ($word)=@_;
	my ($width,$height);

	$pixel_w=$width;
	$pixel_h=$height;

	draw_string($word);

	my $height=@pixels;
	my $width=max (map { $_?scalar(@{$_}):0 } @pixels);

	start_128_gif($width,$height,@background,@foreground);
	for(my $y=0;$y<$height;$y++) { emit_pixel_block($pixels[$y],$width); }
	end_gif();
}

sub max(@)
{
	my $max=pop @_;
	$max=$_>$max?$_:$max for(@_);
	return $max;
}

sub emit_pixel_block($$)
{
	my ($pixels,$num)=@_;
	for(my $i=0;$i<$num;$i++) { emit_gif_pixel($$pixels[$i]); }
}



#
# String drawing
#

my ($scale,$rot,$dx,$dy);

sub draw_string($)
{
	my @chars=split //,$_[0];
	my $x_offs=int(CAPTCHA_HEIGHT/$font_height*2);

	foreach my $char (@chars)
	{
		next unless($font{$char});
		my ($char_w,@strokes)=@{$font{$char}};

		setup_transform($char_w);

		foreach my $stroke (@strokes)
		{
			my @coords=@{$stroke};
			my ($prev_x,$prev_y);

			($prev_x,$prev_y)=transform_coords(shift @coords,shift @coords);

			while(@coords)
			{
				my ($x,$y);
				($x,$y)=transform_coords(shift @coords,shift @coords);

				draw_line($prev_x+$x_offs,$prev_y,$x+$x_offs,$y,1);

				$prev_x=$x;
				$prev_y=$y;
			}
		}
		$x_offs+=int(($char_w+(CAPTCHA_SPACING))*$scale);
	}
}

sub setup_transform($)
{
	my ($char_w)=@_;

	$dx=$char_w/2;
	$dy=$font_height/2;
	$scale=CAPTCHA_HEIGHT/$font_height*(1+(CAPTCHA_SCALING)*(1-rand(2)));
	$rot=(rand(2)-1)*(CAPTCHA_ROTATION);
}

sub transform_coords($$)
{
	my ($x,$y)=@_;

	return (
		int($scale*(cos($rot)*($x-$dx)-sin($rot)*($y-$dy)+$dx+rand(CAPTCHA_SCRIBBLE))),
		int($scale*(sin($rot)*($x-$dx)+cos($rot)*($y-$dy)+$dy+rand(CAPTCHA_SCRIBBLE)))
	);
}

sub draw_line($$$$$)
{
	my ($x1,$y1,$x2,$y2,$col)=@_;
	my ($x,$y,$i,$dx,$dy,$l,$m,$x_inc,$y_inc,$err,$dx2,$dy2);

	$x=$x1; $y=$y1;
	$dx=$x2-$x1; $dy=$y2-$y1;
	$x_inc=($dx<0)?-1:1; $l=$dx*$x_inc;
	$y_inc=($dy<0)?-1:1; $m=$dy*$y_inc;
	$dx2=$l*2; $dy2=$m*2;

	if($l>=$m)
	{
		$err=$dy2-$l;
		for($i=0;$i<$l;$i++)
		{
			draw_pixel($x,$y,$col);
			if($err>0)
			{
				$y+=$y_inc;
				$err-=$dx2;
			}
			$err+=$dy2;
			$x+=$x_inc;
		}
	}
	else
	{
		$err=$dx2-$m;
		for($i=0;$i<$m;$i++)
		{
			draw_pixel($x,$y,$col);
			if($err>0)
			{
				$x+=$x_inc;
				$err-=$dy2;
			}
			$err+=$dx2;
			$y+=$y_inc;
		}
	}
	draw_pixel($x,$y,$col);
}

sub draw_pixel($$$)
{
	my ($x,$y,$col)=@_;

	return if($x<0 or $y<0);

	$pixels[$y][$x]=$col;
	$pixels[$y][$x+1]=$col;
}



#
# GIF generation
#

my ($pixels,$block);

sub start_128_gif($$@)
{
	my ($width,$height,@palette)=@_;
	$pixels=0;
	$block='';

	print pack("A6 vv CCC","GIF89a",$width,$height,0xa6,0,0);
	print pack('CCC'x128,@palette);
	print pack('CCC CvCC',0x21,0xf9,4,0x01,0,0,0);
	print pack('CvvvvCC',0x2c,0,0,$width,$height,0x00,0x07);
}

sub start_128_grey_gif($$@)
{
	my ($width,$height,@palette)=@_;
	$pixels=0;
	$block='';

	print pack("A6 vv CCC","GIF87a",$width,$height,0xa6,0,0);
	for(my $i=0;$i<64;$i++) { print pack('CCC',$i*2,$i*2,$i*2); }
	for(my $i=64;$i<128;$i++) { print pack('CCC',$i*2+1,$i*2+1,$i*2+1); }
	print pack('CvvvvCC',0x2c,0,0,$width,$height,0x00,0x07);
}

sub emit_gif_pixel($)
{
	my ($pixel)=@_;

	emit_gif_byte(0x80) if(($pixels%126)==0);
	emit_gif_byte($pixel);
	$pixels++;
}

sub emit_gif_byte($)
{
	my ($byte)=@_;

	$block.=pack('C',$byte);

	if(length($block)==255)
	{
		print pack('C',255);
		print $block;
		$block='';
	}
}

sub end_gif()
{
	emit_gif_byte(0x81);
	emit_gif_byte(0);

	if($block)
	{
		print pack('C',length($block));
		print $block;
	}
	print pack('C',';');
}