########################################################
# BBSantispam.pm                                       #
# Copyright 2006, HIRAMOTO Kouji. All Rights Reserved. #
########################################################

package BBSantispam;

use strict;

#Digest::MD5モジュールが使用できない等の理由でこれをコメントアウトし
#perl内蔵のcrypt()を使用する時はドキュメント参照のこと。
use Digest::MD5 qw(md5_hex);

#Socketモジュールを使用する場合は lookup_host_ipv4()の先頭を変更してもよい。
#use Socket;

BEGIN {
    use Exporter;
    use vars qw(@ISA @EXPORT);
    @ISA         = qw(Exporter);
    @EXPORT = qw(
		 $BBSantispam_version

		 $SPAN_HOUR
		 $SPAN_DAY
		 $SPAN_WEEK

		 $LOCK_MKDIR
		 $LOCK_LINK
		 $LOCK_SYMLINK
                 );
}
use vars @EXPORT;

$BBSantispam_version = "BBSantispam.pm version 1.3 (2006/03/22)";

## デフォルトのコンフィグファイル名

my $DEFAULT_CONFIG = "./BBSantispam-config.cgi";

## ランダム引数名の寿命

$SPAN_HOUR  = "hour";
$SPAN_DAY   = "day";
$SPAN_WEEK  = "week";

## ロックのタイプ

$LOCK_MKDIR   = "mkdir";
$LOCK_SYMLINK = "symlink";
$LOCK_LINK    = "link";

## ホストのブラックリスト/ホワイトリストのタイプ

my $TYPE_ADDRESS = "type_address";
my $TYPE_HOST    = "type_host";

## オブジェクト内部で情報を保存するために使うキーの名前

my $RANDOM_SET  = "random_set";
my $RANDOM_SET2 = "random_set2";
my $CONFIG      = "config";
my $REASON      = "reason";

## コンフィグファイルの項目名

my $c_arg_length            = "arg_length";
my $c_black_host            = "black_host";
my $c_black_word            = "black_word";
my $c_deny_ascii_post       = "deny_ascii_post";
my $c_deny_illegal_method   = "deny_illegal_method";
my $c_deny_unresolv_address = "deny_unresolv_address";
my $c_deny_unresolv_host    = "deny_unresolv_host";
my $c_illegal_http_host     = "illegal_http_host";
my $c_illegal_http_referer  = "illegal_http_referer";
my $c_lock_wait             = "lock_wait";
my $c_locktype              = "locktype";
my $c_max_url               = "max_url";
my $c_post_wait             = "post_wait";
my $c_random_seed           = "random_seed";
my $c_random_span           = "random_span";
my $c_spamlog               = "spamlog";
my $c_spamlog_lockfile      = "spamlog_lockfile";
my $c_spamlog_separator     = "spamlog_separator";
my $c_white_host            = "white_host";
#v1.1
my $c_viewlog_num           = "viewlog_num";

##

sub new
{
    my $self = {};
    bless $self, "BBSantispam";
    return $self;
}

##

sub read_config
{
    my $self = shift;
    my $file = shift;

    unless ($file) {
	$file = $DEFAULT_CONFIG;
    }

    my $in_handle;
    unless (open($in_handle, "<", $file)) {
	$self->set_reason("cannot open config file $file");
	return 0;
    }
    while (<$in_handle>) {
	next if (/^\#/ or m|^//| or /^[\s\r\n]*$/);
	if (/^([a-z][^=]*)=(.*)$/) {
	    my $key = $1;
	    my $value = $2;
	    $value =~ s/[\r\n]+$//;
	    $self->set_config($key, $value);
	}
	else {
	    $self->set_reason("illegal config $_");
	    return 0;
	}
    }
    close($in_handle);
    return $self;
}

sub set_config
{
    my $self = shift;
    my $key = shift;
    my $value = shift;

    if ($self->{$CONFIG}{$key}) {
	$self->{$CONFIG}{$key} .= ' ';
    }
    if ($key eq $c_spamlog_separator) {
	$value = chr(hex($value));
    }
    $self->{$CONFIG}{$key} .= $value;
    return $self;
}

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

    if ($key) {
	$self->{$CONFIG}{$key} = "";
    }
    else {
	$self->{$CONFIG} = ();
    }
    return $self;
}

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

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

sub print_config
{
    my $self = shift;
    my $result = "";

    foreach my $key (sort keys %{$self->{$CONFIG}}) {
	$result .= sprintf("%s = %s\n", $key, $self->config($key));
    }
    return $result;
}

##

sub is_black_word
{
    my $self = shift;
    my $message = shift;
    foreach my $black (split(/\s+/, $self->config($c_black_word))) {
	if ($message =~ /\Q$black\E/) {
	    $self->set_reason("black word $black");
	    return $black;
	}
    }
    return 0;
}

##

sub set_random_args
{
    my $self = shift;
    my $num = shift;
    my $seed = shift;
    my $span = shift;
    my $ip_address = shift;

    unless ($num) {
	$num = 1;
    }
    unless ($seed) {
	$seed = $self->config($c_random_seed);
    }
    unless ($span) {
	$span = $self->config($c_random_span);
	unless ($span) {
	    $span = $SPAN_HOUR;
	}
    }
    unless ($ip_address) {
	$ip_address = $ENV{'REMOTE_ADDR'};
    }

    my($number, $number2);
    my $time = time;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
    if ($span eq $SPAN_HOUR) {
	$number = "$hour$wday$mday$yday$mon$year";
	($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - 60 * 60);
	$number2 = "$hour$wday$mday$yday$mon$year";
    }
    elsif ($span eq $SPAN_DAY) {
	$number = "$wday$mday$yday$mon$year";
	($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - 60 * 60 * 24);
	$number2 = "$wday$mday$yday$mon$year";
    }
    elsif ($span eq $SPAN_WEEK) {
	$number = "$wday$mon$year";
	($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - 60 * 60 * 24 * 7);
	$number2 = "$wday$mon$year";
    }

    my $ip;
    unless ($ip = $self->is_white_host($ip_address)) {
	$ip = $ip_address;
    }

    my $random_base  = $number . $ip . $seed;
    my $random_base2 = $number2 . $ip . $seed;

    my @keys = ();
    my @keys2 = ();
    my $suffix_list = '0123456789abcdef';
    for (my $i = 0; $i < $num; ++$i) {
	my $suffix = substr($suffix_list, $i, 1);
	push(@keys,  md5_hex($random_base  . $suffix) . $suffix);
	push(@keys2, md5_hex($random_base2 . $suffix) . $suffix);
    }

    $self->{$RANDOM_SET}  = \@keys;
    $self->{$RANDOM_SET2} = \@keys2;
    return $self;
}

# DES crypt版
sub set_random_args_crypt
{
    my $self = shift;
    my $num = shift;
    my $seed = shift;
    my $span = shift;
    my $ip_address = shift;

    unless ($num) {
	$num = 1;
    }
    unless ($seed) {
	$seed = $self->config($c_random_seed);
    }
    unless ($span) {
	$span = $self->config($c_random_span);
	unless ($span) {
	    $span = $SPAN_HOUR;
	}
    }
    unless ($ip_address) {
	$ip_address = $ENV{'REMOTE_ADDR'};
    }

    my $ip;
    unless ($ip = $self->is_white_host($ip_address)) {
	$ip = "1.2.3.4";
    }

    my($ip3, $ip4) = ($ip =~ /^\d+\.\d+\.(\d+)\.(\d+)/);

    my($number, $number2);
    my $time = time;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
    if ($span eq $SPAN_HOUR) {
	$number = sprintf("%02d%02d%2s%1s", $mday, $hour, pack("C", $ip4 % 128), substr($seed, 0, 1));
	($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - 60 * 60);
	$number2 = sprintf("%02d%02d%2s%1s", $mday, $hour, pack("C", $ip4 % 128), substr($seed, 0, 1));
    }
    elsif ($span eq $SPAN_DAY) {
	$number = sprintf("%02d%2s%2s%1s", $mday, pack("C", $ip3 % 128), pack("C", $ip4 % 128), substr($seed, 0, 1));
	($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - 60 * 60 * 24);
	$number2 = sprintf("%02d%2s%2s%1s", $mday, pack("C", $ip3 % 128), pack("C", $ip4 % 128), substr($seed, 0, 1));
    }

    my $random_base  = $number;
    my $random_base2 = $number2;

    my @keys = ();
    my @keys2 = ();
    my $suffix_list = '0123456789abcdef';
    my $salt = substr($seed, 1, 2);
    for (my $i = 0; $i < $num; ++$i) {
	my $suffix = substr($suffix_list, $i, 1);
	push(@keys,  unpack("h*", substr(crypt(($random_base  . $suffix), $salt), 2)) . $suffix);
	push(@keys2, unpack("h*", substr(crypt(($random_base2 . $suffix), $salt), 2)) . $suffix);
    }

    $self->{$RANDOM_SET}  = \@keys;
    $self->{$RANDOM_SET2} = \@keys2;
    return $self;
}

sub random_args
{
    my $self = shift;
    my $set = shift;
    if ($set) {
	return @{$self->{$RANDOM_SET2}};
    }
    else {
	return @{$self->{$RANDOM_SET}};
    }
}

##

sub get_post_wait
{
    my $self = shift;
    my $interval = shift;

    unless ($interval) {
	$interval = $self->config($c_post_wait);
    }
    my $time = time + $interval;
    my $key = "";
    if ($self->config($c_random_seed)) {
	$key = md5_hex($time . $self->config($c_random_seed));
    }
    return ($time, $key);
}

sub get_post_wait_html
{
    my $self = shift;
    my $arg1 = shift;
    my $arg2 = shift;
    my $interval = shift;

    my($time, $key) = $self->get_post_wait($interval);
    my $result = sprintf("<input type=hidden name=%s value=\"%s\">\n",
			 $arg1, $time);
    $result .= sprintf("<input type=hidden name=%s value=\"%s\">\n",
		       $arg2, $key);
    return $result;
}

sub is_too_fast_post
{
    my $self = shift;
    my $time = shift;
    my $key = shift;

    if ($self->config($c_random_seed)) {
	if (md5_hex($time . $self->config($c_random_seed)) ne $key) {
	    $self->set_reason("altered wait");
	    return 2;
	}
    }
    if ($time > time) {
	$self->set_reason("too fast");
	return 1;
    }

    return 0;
}

##

sub is_ascii_post
{
    my $self = shift;
    my $message = shift;

    return 0 unless ($self->config($c_deny_ascii_post));

    if ($message !~ /[\x80-\xff]/) {
	$self->set_reason("ascii post");
	return 1;
    }
    return 0;
}

##

sub is_unresolv_host
{
    my $self = shift;
    my $ip_address = shift;

    unless ($ip_address) {
	$ip_address = $ENV{'REMOTE_ADDR'};
    }

    return 0 if (!$self->config($c_deny_unresolv_address) or
		 $self->is_white_host($ip_address));

    my $cannot_resolv = 1;
    my $host;

    if ($host = $self->lookup_host_ipv4($ip_address)) {
	$cannot_resolv = 0;
    }

    if ($cannot_resolv) {
	$self->set_reason("cannot r-resolv $ip_address");
	return 1;
    }

    if ($self->config($c_deny_unresolv_host) and !($self->lookup_host_ipv4($host))) {
	$self->set_reason("cannot resolv $host");
	return 2;
    }
    return 0;
}

##

sub is_white_host
{
    my $self = shift;
    my $host = shift;
    unless ($host) {
	$host = $ENV{'REMOTE_ADDR'}
    }
    return $self->is_listed_host($self->config($c_white_host), $host);
}

sub is_black_host
{
    my $self = shift;
    my $host = shift;
    unless ($host) {
	$host = $ENV{'REMOTE_ADDR'};
    }
    my $match = $self->is_listed_host($self->config($c_black_host), $host);
    if ($match) {
	$self->set_reason("black host $match");
    }
    return $match;
}

sub is_listed_host
{
    my $self = shift;
    my $host_list = shift;
    my $host = shift;

    my $host_type;
    my $list_type;
    my @host = ($host);

    if ($self->host_type($host) eq $TYPE_ADDRESS) {
	my $h = $self->lookup_host_ipv4($host);
	if ($h) {
	    push(@host, $h);
	}
    }

    my $match = "";
    foreach $host (@host) {
	$host_type = $self->host_type($host);
	foreach my $list (split(/\s+/, $host_list)) {
	    if ($list =~ /^regex:/) {
		my $list_orig = $list;
		$list =~ s/^regex://;
		if ($host =~ /$list/) {
		    $match = $list_orig;
		    last;
		}
	    }
	    else {
		$list_type = $self->host_type($list);
		if ($host_type ne $list_type) {
		    next;
		}
		my $list_orig = $list;
		$list =~ s/\./\\./g;
		$list =~ s/\*/.*/g;
		if ($list_type eq $TYPE_ADDRESS and $host =~ /^$list/ or
		    $host =~ /$list$/) {
		    $match = $list_orig;
		    last;
		}
	    }
	}
    }
    return $match;
}

sub host_type
{
    my $self = shift;
    my $host = shift;
    return ($host =~ /^[\d*.]+$/ ? $TYPE_ADDRESS : $TYPE_HOST);
}

##

sub is_many_url
{
    my $self = shift;
    my $message = shift;
    my $max_url = shift;

    return 0 if ($self->config($c_max_url) <= -1);

    unless (defined($max_url)) {
	$max_url = $self->config($c_max_url);
    }
    return 0 if ($max_url <= -1);

    my @urls = ($message =~ m|https?://|ig);
    if ($#urls + 1 >= $max_url) {
	$self->set_reason("many url " . ($#urls + 1));
	return 1;
    }
    return 0;
}

##

sub is_illegal_method
{
    my $self = shift;
    my $method = shift;

    return 0 unless ($self->config($c_deny_illegal_method));

    unless ($method) {
	$method = $ENV{'REQUEST_METHOD'};
    }
    if ($method ne 'GET' and $method ne 'HEAD') {
	$self->set_reason("illegal method $method");
	return 1;
    }
    return 0;
}

##

sub is_illegal_http_host
{
    my $self = shift;
    my $http_host = shift;

    return 0 unless ($self->config($c_illegal_http_host));
    unless ($http_host) {
	$http_host = $ENV{'HTTP_HOST'};
    }
    return $self->is_illegal_header('HTTP_HOST',
				    $self->config($c_illegal_http_host),
				    $http_host);
}

sub is_illegal_http_referer
{
    my $self = shift;
    my $http_referer = shift;

    return 0 unless ($self->config($c_illegal_http_referer));
    unless ($http_referer) {
	$http_referer = $ENV{'HTTP_REFERER'};
    }
    return $self->is_illegal_header('HTTP_REFERER',
				    $self->config($c_illegal_http_referer),
				    $http_referer);
}

sub is_illegal_header
{
    my $self = shift;
    my $header_name = shift;
    my $illegal_list = shift;
    my $header_data = shift;

    unless ($header_data) {
	$header_data = $ENV{$header_name};
    }

    foreach my $illegal (split(/\s+/, $illegal_list)) {
	if ($header_data =~ /\Q$illegal\E/) {
	    $self->set_reason("illegal $header_name $illegal");
	    return $illegal;
	}
    }
    return 0;
}

##

sub search_args
{
    my $self = shift;
    my $length = $self->config($c_arg_length);
    return sort { substr($a, $length - 1, 1) cmp substr($b, $length - 1, 1) } grep { length == $length } @_;
}

sub log
{
    my $self = shift;
    my(@log) = @_;

    my $logfile = $self->config($c_spamlog);
    return 0 unless ($logfile);

    $self->lock or return 0;

    my $out_handle;
    open($out_handle, ">>", $logfile) or return 0;

    printf $out_handle ("%d.%d", time, $$);

    my $separator = $self->config($c_spamlog_separator);
    if ($separator eq "") {
	$separator = "\t";
    }
    foreach my $data (@log) {
	$data =~ s/\r//g;
	$data =~ s/\n/\\n/g;
	print $out_handle $separator, $data;
    }

    print $out_handle "\n";

    close($out_handle) or return 0;

    $self->unlock or return 0;

    return 1;
}

sub view_log
{
    my $self = shift;
    my $format = shift;
    my $option = shift;
    my $ME = shift;

    my $logfile = $self->config($c_spamlog);
    return 0 unless ($logfile);

    my $detail_mode = 0;
    if ($option) {
	$detail_mode = 1;
    }

    my $in_handle;
    open($in_handle, "<", $logfile) or return 0;
    my $log = "";
    my $separator = $self->config($c_spamlog_separator);

    unless ($ME) {
	$ME = $self->get_cgi_name;
    }

    if ($option =~ /^\d+\.\d+$/) {
	while (<$in_handle>) {
	    last if (/^\Q$option\E/);
	}
	$log .= "<table border=1>\n";
	my $count = 0;
	my @format = split(/,/, $format);
	foreach my $arg (split(/$separator/, $_)) {
	    $log .= "<tr><th>";
	    my $f1 = shift @format;
	    $f1 =~ s/^.//;
	    $log .= $f1;
	    $log .= "</th><td>";
	    if ($count == 0) {
		$log .= $self->date_time($arg);
	    }
	    else {
		$log .= $arg;
	    }
	    $log .= "</td></tr>\n";
	    ++$count;
	}
	$log .= "</table>\n";
    }
    else {
	my $page = 1;
	if ($option =~ /^p(\d+)$/) {
	    $page = $1;
	}

	my @log = ();
	while (<$in_handle>) {
	    unshift(@log, $_);
	}

	my($log_num) = ($self->config($c_viewlog_num) or 10);

	my $start = ($page - 1) * $log_num;
	my $end   = $page * $log_num - 1;
	my $h2 = "<tr>";
	foreach my $f1 (".No.", split(/,/, $format)) {
	    if ($f1 !~ /^\#/) {
		my $f2 = $f1;
		$f2 =~ s/^.//;
		$h2 .= "<th>$f2</th>";
	    }
	}
	$h2 .= "</tr>\n";

	my $loop_count = $start + 1;
	for (my $i = $start; $i <= $end; ++$i) {
	    $_ = $log[$i];
	    chomp;
	    $log .= "<tr>";
	    my @format2 = split(/,/, $format);
	    my $l = "";
	    my $count = 0;
	    my $link;

	    foreach my $arg (split(/$separator/, $_)) {
		if ($count == 0) {
		    $link = $arg;
		    $l .= sprintf("<th><a href=\"%s?%s\">%d</a></th>",
				  $ME, $link,
				  $loop_count);
		    $l .= "<td>" . $self->date_time($arg) . "</td>";
		}
		elsif ($format2[$count] =~ /^\#/) {
		    $l .= "";
		}
		elsif ($format2[$count] =~ /^L/) {
		    if ($arg) {
			$l .= "<td><a href=\"$ME?$link\">click</a></td>";
		    }
		    else {
			$l .= "<td>-</td>";
		    }
		}
		elsif ($format2[$count] =~ /^r/) {
		    $l .= "<td align=right>$arg</td>";
		}
		else {
		    $l .= "<td>$arg</td>";
		}
		++$count;
	    }
	    $l .= "</tr>\n";
	    $log .= $l;
	    ++$loop_count;
	}

	$log = "<table border=1>\n$h2\n$log\n</table>\n";

	my $l = "";
	for (my $i = 0; $i <= $#log / $log_num; ++$i) {
	    if ($page - 1 == $i) {
		$l .= sprintf("_%d_|", $i + 1);
	    }
	    else {
		$l .= sprintf("<a href=\"%s?p%d\">_%d_</a>|", $ME, $i + 1, $i + 1);
	    }
	}
	$log .= $l;
    }

    close($in_handle);

    return $log;
}

sub get_cgi_name
{
    my $self = shift;
    my $me = shift;

    if ($ENV{"SCRIPT_NAME"}) {
        $me = $ENV{"SCRIPT_NAME"};
    }
    elsif ($ENV{"REQUEST_URI"}) {
        $me = $ENV{"REQUEST_URI"};
    }
    elsif ($0) {
        $me = $0;
        $me =~ s|^.*/||;
    }
    $me =~ s/\?.*$//;
    return $me;
}

##

sub lock
{
    my $self = shift;
    my $lockfile = $self->config($c_spamlog_lockfile);
    my $wait     = $self->config($c_lock_wait);
    my $locktype = $self->config($c_locktype);

    while ($wait > 0) {
	if ($locktype eq $LOCK_SYMLINK and symlink('.', $lockfile) or
	    $locktype eq $LOCK_MKDIR   and mkdir($lockfile, 0777)) {
	    last;
	}
	my $sleep = int(rand(2)) + 1;
	sleep $sleep;
	$wait -= $sleep;
    }

    if ($wait >= 0) {
	return 1;
    }
    return 0;
}

sub unlock
{
    my $self = shift;
    my $lockfile = $self->config($c_spamlog_lockfile);
    my $locktype = $self->config($c_locktype);

    if ($locktype eq $LOCK_SYMLINK and unlink($lockfile) or
	$locktype eq $LOCK_MKDIR   and rmdir($lockfile)) {
	return 1;
    }
    return 0;
}

sub date_time
{
    my $self = shift;
    my $time = shift;
    $time =~ s/\..*$//;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
    return sprintf("%04d/%02d/%02d %02d:%02d:%02d",
		   1900 + $year, $mon + 1, $mday,
		   $hour, $min, $sec);
}

##

sub set_reason
{
    my $self = shift;
    my $reason = shift;

    $self->{$REASON} = $reason;
    return $self;
}

sub reason
{
    my $self = shift;
    return $self->{$REASON};
}

##

sub lookup_host_ipv4
{
    my $self = shift;
    my $host = shift;

    #use Socket を使う場合の設定。
    #my $q_type = AF_INET;
    #sub lookup_host_ipv4_ntoa { inet_ntoa($_[0]); }

    #use Socket を使わない場合の設定。
    my $q_type = 2;
    sub lookup_host_ipv4_ntoa { join(".", unpack("C4", $_[0])) }

    my $q_is_addr = ($host =~ /^[\d.]+$/ ? 1 : 0);
    my @result = ();
    if ($q_is_addr) {
	my $addr = pack("C4", split(/\./, $host));
	@result = gethostbyaddr($addr, $q_type);
    }
    else {
	@result = gethostbyname($host);
    }

    if ($#result <= -1) {
	return "";
    }

    my($name, $aliases, $addrtype, $length, @addrs) = @result;
    if ($q_is_addr) {
	return $name;
    }
    else {
	my $addrs = "";
	foreach my $ad (@addrs) {
	    $addrs .= &lookup_host_ipv4_ntoa($ad);
	    $addrs .= " ";
	}
	chop $addrs;
	return $addrs;
    }
}

1;

__END__

=head1 NAME

BBSantispam - 掲示板CGIに対してアンチスパム機能を提供するライブラリ

=head1 SYNOPSIS

 use BBSantispam;
 $antispam = BBSantispam::new;
	:
 if ($antispam->is_black_word($message)) {
     &error("禁止語句が含まれています");
 }
	:
 ($time, $key) = $antispam->get_post_wait;
 print "<input type=hidden name=wait value=$time>\n";
 print "<input type=hidden name=wait_key value=$key>\n";
 	:
 if ($antispam->is_too_fast_post($arg{'wait'}, $arg{'wait_key'})) {
     &error("投稿が速すぎるか、引数が改竄されてます");
 }

=head1 DESCRIPTION

I<BBSantispam> は、掲示板CGIへのスパム投稿を防ぐ以下のような機能を提供します。

=head2 各種判定

以下の判定を行うメソッドを提供します。

=over 4

=item *

IPアドレスやホスト名のブラックリスト、ホワイトリスト

=item *

禁止語句のブラックリスト

=item *

フォーム表示から投稿までが速すぎる

=item *

ホストのIPアドレスが逆引きできる

=item *

逆引きして得たホスト名が正引きできる

=item *

英文のみの投稿

=item *

投稿文中にURLがたくさん含まれている

=item *

想定していないHTTPメソッドでのアクセス

=item *

HTTPヘッダにおかしな情報が含まれている

=back

=head2 CGI引数のランダム化支援

CGI引数用のランダムな文字列を提供し、POSTのみを行ったり、フォーム取得と投稿を異なるホストから行うロボットからのスパム投稿を防ぎます。

=head2 ログ作成

ログファイルを作成する機能を提供します。
スパムと判断したアクセスや投稿内容を簡単にログに保存できます。

=head1 CONSTRUCTOR

=over 4

=item new

新しい BBSantispam オブジェクトのコンストラクタを作成します。

=back

=head1 METHODS

=head2 コンフィグ

=over 4

=item read_config ( [ CONFIG_FILE ] )

コンフィグファイルを読み込みます。
C<CONFIG_FILE> を指定すればそれをコンフィグファイルとみなします。
指定しない場合はデフォルトのコンフィグファイル
(カレントディレクトリのF<BBSantispam-config.cgi>)を読み込みます。

I<read_config> を複数回呼び出した場合、設定がどんどん追加されていきます。
これを利用して設定ファイルを分割管理することも可能です。

=item set_config ( KEY , VALUE )

コンフィグ項目 C<KEY> に対して値 C<VALUE> を設定します。

=item reset_config ( [ KEY ] )

コンフィグ項目 C<KEY> を削除します。
C<KEY> が省略された場合、すべてのコンフィグを削除します。

=item config ( [ KEY ] )

コンフィグ項目 C<KEY> の値を読み出します。

返り値: コンフィグ項目 C<KEY> に対応する値を返します。

=item print_config

すべてのコンフィグ内容をテキスト形式で取得します。デバッグ用。

返り値: コンフィグ内容を表す文字列。

=back

=head2 アクセス制限・許可

=over 4

=item is_black_host ( [ HOST ] )

アクセスしてきたホストが、IPアドレスやホスト名のブラックリストに一致するかどうかを判定します。
ブラックリストはコンフィグの I<black_host> で設定します。
C<HOST> を省略した場合は環境変数REMOTE_ADDRの値が使用されます。

返り値: ブラックリストに一致しない場合は空文字列 "" を返します。
一致した場合は一致したリスト項目を返し、reason() メソッドで C<black host HOST> (C<HOST> は一致したブラックリスト項目)という情報を得ることができます。

=item is_white_host ( [ HOST ] )

アクセスしてきたホストが、IPアドレスやホスト名のホワイトリストに一致するかどうかを判定します。
ホワイトリストはコンフィグの I<white_host> で設定します。
C<HOST> を省略した場合は環境変数REMOTE_ADDRの値が使用されます。

返り値: ホワイトリストに一致しない場合は空文字列 "" を返し、一致した場合は一致したリスト項目を返します。

=item is_unresolv_host ( [ HOST ] )

アクセスしてきたホストのIPアドレスが逆引きできるか、また逆引きして得たホスト名が正引きできるかを判定します(正引き・逆引きの一致までは判定しません)。
それぞれの判定を行うかどうかはコンフィグの I<deny_unresolv_address> および I<deny_unresolv_host> で設定します。
C<HOST> を省略した場合は環境変数REMOTE_ADDRの値が使用されます。

返り値: 逆引きも正引きも問題なければ 0 を、逆引きできなければ 1 を、正引きできなければ 2 を返します。

=item is_illegal_method ( [ METHOD ] )

GET/HEAD以外のHTTPメソッドでアクセスされているかどうかを判定します。
C<METHOD> を省略した場合は環境変数REQUEST_METHODの値が使用されます。
本来GETでしかアクセスされないはずのCGIに対してPOST等でアクセスしてくるクライアントを判別するために使用します。

返り値: GET/HEADメソッドの場合は 0 を、それ以外の場合は 1 を返します。

=item is_illegal_http_host ( [ STRING ] )

HTTPのHost:ヘッダ(環境変数HTTP_HOST)に特定の文字列が含まれているかどうかを判定します。
マッチする文字列はコンフィグの I<illegal_http_host> で指定します。
C<STRING> を省略すると環境変数HTTP_HOSTの値を使用します。

返り値: マッチした場合はそのパターンを返します。マッチしない場合は 0 を返します。

=item is_illegal_http_referer ( [ STRING ] )

HTTPのReferer:ヘッダ(環境変数HTTP_REFERER)に特定の文字列が含まれているかどうかを判定します。
マッチする文字列はコンフィグの I<illegal_http_referer> で指定します。
C<STRING> を省略すると環境変数HTTP_REFERERの値を使用します。

返り値: マッチした場合はそのパターンを返します。マッチしない場合は 0 を返します。

=back

=head2 語句制限

=over 4

=item is_black_word ( [ MESSAGE ] )

コンフィグの I<black_word> で設定したブラックリストの語句が C<MESSAGE> に含まれているかどうかを判断します。
含まれている場合は一致した語句を返します。
含まれていない場合は 0 を返します。

=back

=head2 CGI引数のランダム化支援

=over 4

=item set_random_args ( [ NUM , SEED , SPAN , HOST ] )

CGI引数用のランダムな文字列を生成します。

C<NUM> は生成する文字列の個数を設定します。
省略した場合、生成される文字列は1つです。

C<SEED> はランダムな文字列の種となる文字列を指定します。
省略した場合、コンフィグの I<random_seed> が使用されます。

C<SPAN> はランダムな文字列の有効期限を指定します。
"hour"を指定すると1時間、"day"なら1日間、"week"なら1週間です。
省略した場合"hour"とみなします。

C<HOST> はアクセス元を一意に表す文字列を指定します。
通常はアクセス元のIPアドレスです。
省略した場合はアクセス元のIPアドレスを使用しますが、
アクセス元が I<white_host> に一致した場合はその一致パターンが使用されます。

=item random_args ( [ SET ] )

I<set_random_args> で生成した文字列をリストの形式で返します。
C<SET> に1を指定すると、 I<set_random_args> の C<SPAN> で指定した期限の1つ前の文字列リストを返します。
(例えば C<SPAN> で"hour"を指定した場合、 I<random_args(1)> は1時間前に生成されたであろう文字列リストを返します)

=item search_args ( LIST )

CGIの引数のリストを C<LIST> で与えると、ランダムなCGI引数と思われるものを抽出します。
CGIの引数が I<random_args> で得られるどの文字列にも一致しない場合に使用します。
(これで引数を探す必要があるというのは、おそらく何らかのspam投稿でしょう)

=back

=head2 投稿までの所用時間による制限

=over 4

=item get_post_wait ( [ INTERVAL ] )

投稿を許可する時間情報を返します。
C<INTERVAL> は、このメソッドを呼び出してから投稿を許可するまでの時間を秒で指定します。
省略した場合、コンフィグの I<post_wait> が使用されます。

返り値: 投稿を許可する時間(現時点のtime()の返り値に C<INTERVAL> を加えた数字)と、その値を検証するためのハッシュキーからなるリストを返します。
この2つの値をCGIのフォームにhidden属性で埋め込み、後で I<is_too_fast_post> での検証に利用します。

=item get_post_wait_html ( ARG1, ARG2 [, INTERVAL ] )

get_post_wait のコンビニエンス関数で、以下のようなHTMLコードを直接得ます。

 <input type=hidden name=ARG1 value="TIME">
 <input type=hidden name=ARG2 value="HASHKEY">

C<TIME> と C<HASHKEY> は get_post_wait メソッドの返り値です。

=item is_too_fast_post ( TIME, HASHKEY )

投稿可能な時間かどうかを判定します。
C<TIME> と C<HASHKEY> は I<get_post_wait> で得た値です。

返り値: 投稿可能な時間になっていれば 0 を、そうでなければ 1 を、 C<TIME> の値が改竄されている場合は 2 を返します。

=back

=head2 投稿内容による制限

=over 4

=item is_ascii_post ( MESSAGE )

C<MESSAGE> が英文のみかどうかを判別します。
判別するかどうかはコンフィグの I<deny_ascii_post> で設定できます。

返り値: 英文のみならば 1 を、そうでなれば 0 を返します。

=item is_many_url ( MESSAGE [, NUM ] )

C<MESSAGE> にURLと思われる文字列が C<NUM> 個以上含まれているかどうかを判別します。
C<NUM> を省略した場合、コンフィグの I<max_url> が使用されます。
C<NUM> が -1 以下の場合は何もしません。

返り値: URLが C<NUM> 個以上ならば 1 を、そうればければ 0 を返します。

=back

=head2 ログ作成

=over 4

=item log ( LIST )

ログを出力します。
出力内容の引数 C<LIST> はリストの形式で与えます。

ログファイル名はコンフィグの I<spamlog> で設定します。
I<spamlog> が設定されていない場合はログファイルは生成されません。

ログの形式はいわゆるCSVで、区切り記号はコンフィグの I<spamlog_separator> で設定します。
設定がなければタブ文字が使用されます。

またログファイルの第1カラム目は、ログが記録された時間(time関数の返り値)とCGIのPIDをピリオドで連結したものになります。

=item view_log ( FORMAT , OPTION [, CGI ] )

ログファイルを読み出し、HTML のテーブルに整形した結果を得ます。
引数の与え方によって「一覧表示」と「詳細表示」が可能です。

C<FORMAT> は、ログファイルの各項目名と、各項目の一覧表示での書式を指定します。
書式は以下の1文字で指定します。

=over 4

=item .

そのまま出力します。

=item #

出力しません。

=item r

右寄せで出力します。

=item L

「詳細表示」へのリンクを「click」という文字列で出力します。

=back

書式に続けて任意の項目名を指定します。
書式と項目名の組は、カンマで区切って必要個数記述できます。

例えばログの項目が『日時』『理由』『IPアドレス』『名前』『メール』『題名』『URL』『コメント』の順で並んでおり、
「『日時』『理由』『IPアドレス』は表示、『名前』『メール』『題名』『URL』は非表示、『コメント』はリンク」としたい場合は、次のように指定します。

 ".日時,.理由,.IPアドレス,.名前,.メール,.題名,.URL,Lコメント"

C<OPTION> が指定されていない場合は一覧表示を、「p(数字)」が指定されている場合は指定ページを、ログの記録時間が指定されている場合は指定されたログの詳細表示を行います。

C<CGI> は詳細表示へのリンクを出力する際のCGI名です。
省略した場合は環境変数 SCRIPT_NAME, REQUEST_URI や $0 から推測したCGI名が使用されます。

=item reason

投稿やアクセスがspamであると各メソッドが判断した場合、その判断理由をこのメソッドで取り出すことができます。

=item lookup_host_ipv4 ( HOST )

C<HOST>の名前解決をします。

返り値: C<HOST>がIPアドレスの場合は、逆引きしたホスト名を返します。
C<HOST>がホスト名の場合は、正引きしたIPアドレスを返します。
複数のIPアドレスが設定されている場合はそれらを空白で連結した値を返します。

=back

=head1 CONFIGURATION

コンフィグファイルは「設定項目=設定値」という書式です。
行頭が「#」または「//」の行はコメントとして扱われます。
同じキーワードが複数回出てきた時は、設定値はスペースで区切られて連結されます。

例: 以下の2つの設定の結果は同じ。

 #まとめて書く
 black_host=192.168.0.1 host.example.com

 #分けて書く
 black_host=192.168.0.1
 black_host=host.example.com

注意: コンフィグファイルを設定しても、掲示板プログラム側で BBSantispam の各メソッドを利用した判定ルーチン等を組み込んでいなければ、意味がありません。

=over 4

=item black_host=( HOST ... )

関連メソッド: I<is_black_host>

接続元(掲示板閲覧者/投稿者)のIPアドレスやホスト名のブラックリストを設定します。
C<HOST> はホスト名またはIPアドレスで、アスタリスク(*)を使ったワイルドカードでの記述も可能です。
またホスト名が「regex:」で始まる場合は、perlの完全な正規表現でパターンを記述することができます。

例:

 black_host=192.168.0.1 172.16.0.* host.example.com *.example.jp
 black_host=regex:p[0-9]*-ip.*\.example\.jp

=item white_host=( HOST ... )

関連メソッド: I<is_white_host>, I<set_random_args>

接続元(掲示板閲覧者/投稿者)のIPアドレスやホスト名のホワイトリストを設定します。
C<HOST> はホスト名またはIPアドレスで、アスタリスク(*)を使ったワイルドカードでの記述も可能です。
またホスト名が「regex:」で始まる場合は、perlの完全な正規表現でパターンを記述することができます。

例:

 white_host=192.168.0.1 172.16.0.* host.example.com *.example.jp
 white_host=regex:p[0-9]*-ip.*\.example\.jp

=item deny_unresolv_address=( 1 | 0 )

関連メソッド: I<is_unresolv_host>

1を設定すると、接続元(掲示板閲覧者/投稿者)のIPアドレスが逆引きできるかどうかを判定します。

=item deny_unresolv_host=( 1 | 0 )

関連メソッド: I<is_unresolv_host>

1を設定すると、接続元(掲示板閲覧者/投稿者)のIPアドレスを逆引きして得たホスト名が正引きできるかどうかを判定します。

=item deny_ascii_post=( 1 | 0 )

関連メソッド: I<is_ascii_post>

1を設定すると、投稿内容が英字のみかどうか(日本語を含まないかどうか)を判定します。

=item max_url=( NUM )

関連メソッド: I<is_many_url>

spamとみなすURLの数を指定します。

=item post_wait=( SECOND )

関連メソッド: I<get_post_wait>

フォーム表示から投稿可能になるまでの時間を指定します。

=item deny_illegal_method=( 1 | 0 )

関連メソッド: I<is_illegal_method>

1を設定すると、POST/GET以外のHTTPメソッドかどうかを判定します。

=item illegal_http_host=( STRING ... )

関連メソッド: I<is_illegal_http_host>

HTTPのHost:ヘッダ(環境変数HTTP_HOST)に含まれていてはいけない文字列を指定します。

=item illegal_http_referer=( STRING ... )

関連メソッド: I<is_illegal_http_referer>

HTTPのReferer:ヘッダ(環境変数HTTP_REFERER)に含まれていてはいけない文字列を指定します。

=item random_seed=( STRING )

関連メソッド: I<set_random_args>, I<get_post_wait>, I<is_too_fast_post>

ランダムなCGI引数や、投稿までの時間を検証するハッシュキーを生成するための種(シード)を設定します。

ここで設定する値は BBSantispam を利用するにあたって特に覚えておく必要はありません。
推測や辞書攻撃を防ぐために、十分に長い日本語やランダムな文字列を設定してください。
文字数制限は特にありません。

例えば以下のような方法を推奨します。

=over 4

=item asahi.com等のニュースサイトの適当な記事から数十文字コピー&ペーストペする。

=item エディタ上でキーボードを適当に叩いてそこから数十文字コピー&ペーストペする。

=item 付属の get-random-seed.pl でランダムな文字列を生成する。

=back

注意: 掲示板の設置時には、デフォルトの設定値から必ず変更してください。

=item spamlog=( FILENAME )

関連メソッド: I<log>, I<view_log>

出力するログファイル名を指定します。
指定しない場合はログファイルは生成されません。

=item spamlog_separator=( HEX )

関連メソッド: I<log>, I<view_log>

出力するログファイルの、各項目を区切るセパレータの文字を16進数で指定します。

=item locktype=( symlink | mkdir )

関連メソッド: I<lock>, I<unlock>, I<log>

I<log> メソッドでログを出力する際の、排他処理を行うためのロックを行う方式を指定します。

=over 4

=item mkdir

mkdir()関数でディレクトリを作成してロックを行います。

=item symlink

symlink()関数でシンボリックリンクを作成してロックを行います。

=item (指定しない)

ロックは行いません。(場合によってはログファイルが破壊されますので、お勧めできません)

=back

もっとも多くのOSで動作するのはおそらく mkdir ですが、
組み込み対象の掲示板プログラムに合わせるのが一番確実です。

=item lock_wait=( SECOND )

関連メソッド: I<lock>, I<unlock>, I<log>

ロックを行う際の最大待ち時間を指定します。

=item spamlog_lockfile=( FILENAME )

関連メソッド: I<lock>, I<unlock>, I<log>

ロックファイル名を指定します。

=item arg_length=( NUM )

関連メソッド: I<set_random_args>, I<search_args>

ランダム引数の長さを指定します。
通常は md5_hex() が生成する 32文字 + 末尾に 1文字追加の計 33文字になるので 33を指定します。

=item random_span=( hour | day | week )

関連メソッド: I<set_random_args>

ランダム引数が変化する時間の間隔(=ランダム引数の寿命)を指定します。

=item viewlog_num=( NUM )

関連メソッド: I<view_log>

ログを表示する場合の、1ページあたりの件数を指定します。

=over 4

=item hour

1時間毎に変化します。

=item day

1日毎に変化します。

=item week

1週間毎に変化します。

=back

=back

=head1 掲示板プログラムに組み込むにあたって

I<BBSantispam> を掲示板プログラムに組み込む時のヒント。

=head2 初期化

プログラムの先頭に

 use BBSantispam;

を、またプログラムの序盤に

 $antispam = BBSantispam::new;
 $antispam->read_config;

を入れ、 I<$antispam> でメソッドを呼び出せるようにしてください。
(perlのオブジェクト指向プログラミングについては、perlの書籍等を参考にしてください。
ここでは特に触れません。)

=head2 判定系のメソッド

I<is_> で始まる判定系のメソッドは、そのまま条件判断に組み込んで使えます。

例: $in{'comment'}に投稿フォームの入力値が入っている場合。

 if ($antispam->is_many_url($in{'comment'})) {
     &error("URLが多すぎます");
 }

=head2 CGI引数のランダム化

perlでCGI引数を扱う場合、ハッシュで管理することが多いと思います。
CGI引数のランダム化は基本的にそれを前提としています。

以下、例を挙げて説明します。
(既存の掲示板CGIで)フォーム内容が %in というハッシュに格納されているとします。
そして名前を $in{'name`} 投稿文面を $in{'comment'} として扱っているとします。

まずCGIプログラムを修正し、$in{'name`} は $in{$RNDname}、$in{'comment'} は $in{$RNDcomment} というようにハッシュのキーを変数にし、これで正常に動作することを確認します。
もちろん事前に $RNDname = 'name'; などと設定しておくのを忘れずに。
また既存の変数名とぶつからないようにしてください。

次にランダム化の組み込みですが、この例の場合扱う要素は 2つですので、$RNDname や $RNDcomment の初期化部分を

 $antispam->set_random_args(2);
 ($RNDname, $RNDcomment) = $antispam->random_args;

とします。これでCGIの引数がランダム化されているはずなので、WebブラウザでHTMLソースを表示させるなどして確認してみてください。

しかしこれだけだと、set_random_args の C<SPAN> 引数による有効期限の切れ目で引数名が変化してしまいます。
例えば 10時58分にフォームを表示した時と 11時02分に投稿した時では、プログラムが取り扱う引数名が変化してしまい投稿に失敗する、ということが発生します。
これを回避するために、フォームの値を取得する部分あたりで

 if (! defined($in{$RNDcomment})) {
     my($RNDname2, $RNDcomment2) = $antispam->random_args(1);
     if (defined($in{$RNDcomment2})) {
         $RNDname = $RNDname2;
         $RNDcomment = $RNDcomment2;
     }
 }

というルーチンを組み込み、1スパン分古い引数についても面倒を見るようにします。

=head2 ログ出力

以下のようなラッパー関数を用意して、spamと判断したら呼び出します。

例: %in に投稿フォームの各種情報が格納されている場合。

 sub spamlog
 {
     my ($name, $sub, $comment, $email, $url);
     unless ($in{$comment}) {
         ($name, $sub, $comment, $email, $url) =
             $antispam->search_args(keys %in);
     }
     $antispam->log($antispam->reason,
                    $ENV{'REMOTE_ADDR'},
                    $in{$url},
                    $in{$email},
                    $in{$name},
                    $in{$sub},
                    $in{$comment});
 }

=head1 Digest::MD5が利用できない場合

ソースを以下のように修正することで、 Digest::MD5 の md5_hex() の代わりに
perl 標準の crypt() 関数を使用できます。

=head2 修正方法

=over 4

=item *

「use Digest::MD5 qw(md5_hex);」をコメントアウトします。

=item *

「sub set_random_args」を「sub set_random_args_md5」に、
「sub set_random_args_crypt」を「sub set_random_args」に書き換えます。

=item *

コンフィグの「random_seed=」を 3文字の英数字に、
「arg_length」を 23 に変更します。

=back

=head2 crypt() 使用時の制限

=over 4

=item *

コンフィグの spam で設定できるのは「hour」「day」のみとなります。
「week」は使用できません。

=item *

ホワイトリスに一致した場合の引数が、
通常はホワイトリストの項目毎に同じ引数が使用されるのに対し、
ホワイトリストのどの項目に一致しても同じ引数が使用されるようになります。

=item *

コンフィグの「random_seed=」は必ず 3文字の英数字でなければなりません。

=item *

MD5 の代わりに crypt を使用するので、
引数のランダム化のアルゴリズムがとても弱くなります。

=item *

DES版の crypt() であることを前提にしています。
MD5版の crypt() である場合、どのような挙動になるか未確認です。
またこの改造自体、ほとんどテストをしていません。

=back

=head1 AUTHOR

HIRAMOTO Kouji (http://flatray.com/)

=head1 BUGS

あったら報告していただけると嬉しいです。

=head1 SEE ALSO

http://flatray.com/

=head1 COPYRIGHT

Copyright 2006, HIRAMOTO Kouji. All Rights Reserved.

コードやアルゴリズムなどの流用は自由に行っていただいて構いませんし、
特に連絡もいりません。
しかし、丸々パクって自分の著作であると主張したりというような
恥ずかしい行為だけはご遠慮ください。

=cut