/dada/DADA/perllib/WWW/StopForumSpam.pm
Perl | 309 lines | 229 code | 68 blank | 12 comment | 33 complexity | 00daceec118973b511aaefc17488dad8 MD5 | raw file
Possible License(s): GPL-2.0
- package WWW::StopForumSpam;
- use 5.010;
- use strict;
- use warnings;
- use autodie;
- use Carp qw(croak);
- use URI::Escape;
- use Digest::MD5 qw(md5_hex);
- use Socket;
- use WWW::Curl::Easy;
- use JSON qw(decode_json);
- our $VERSION = '0.02';
- sub new {
- my $class = shift;
- my $self = bless({}, $class);
- # parse params
- while(@_) {
- my $attr = shift;
- my $value = shift;
-
- if($attr eq "timeout") {
- $self->{timeout} = 0 + $value;
- } elsif($attr eq "api_key") {
- $self->{api_key} = "$value";
- } elsif($attr eq "api_url") {
- $self->{api_url} = "$value";
- } elsif($attr eq "dnsbl") {
- $self->{dnsbl} = "$value";
- } elsif($attr eq "treshold") {
- $self->{treshold} = 0 + $value;
- }
- }
-
- # validate / set defaults
- $self->{api_url} = "http://www.stopforumspam.com/api" unless exists $self->{api_url};
- $self->{dnsbl} = "sfs.dnsbl.st." unless exists $self->{dnsbl};
- $self->{timeout} = 4 unless exists $self->{timeout};
- $self->{connect_timeout} = $self->_ceil($self->{timeout} / 2);
- $self->{treshold} = 65 unless exists $self->{treshold};
- return $self;
- }
- sub check {
- my $self = shift;
- my @request_params = ();
-
- while(@_) {
- my $attr = shift;
- my $value = shift;
-
- if ($attr eq "ip" or $attr eq "email" or $attr eq "username") {
- push(@request_params, $attr . "=" . uri_escape($value));
- }
- }
-
- # add default params
- push(@request_params, "f=json");
-
- my ($http_code, $buffer) = $self->_query_api(join("&", @request_params));
-
- # if the api is not working, we don't want to allow potential spammers
- # signing up, so rather force the developers to check their logs...
- if (not defined $buffer) {
- return 1;
- }
-
- my $decoded_json = decode_json($buffer);
- if(not defined $decoded_json->{'success'}) {
- warn "unable to read json";
- return 1;
- } elsif($decoded_json->{'success'} == 0) {
- warn $decoded_json->{'error'};
- return 1;
- }
-
- if($self->_get_avg_confidence($decoded_json) > $self->{treshold}) {
- return 1;
- }
-
- return 0;
- }
- sub dns_check {
- my $self = shift;
-
- my $packed_ip;
- my $ip_address;
-
- while(@_) {
- my $attr = shift;
- my $value = shift;
-
- if ($attr eq "ip") {
- $packed_ip = gethostbyname(join('.', reverse split(/\./, $value)) . "." . $self->{dnsbl});
- if (not defined $packed_ip) {
- next;
- }
-
- $ip_address = inet_ntoa($packed_ip);
- if ($ip_address eq "127.0.0.2") {
- return 1;
- }
-
- } elsif ($attr eq "email") {
- $packed_ip = gethostbyname(md5_hex($value) . "." . $self->{dnsbl});
- if (not defined $packed_ip) {
- next;
- }
-
- $ip_address = inet_ntoa($packed_ip);
- if ($ip_address eq "127.0.0.3") {
- return 1;
- }
- }
- }
-
- return 0;
- }
- sub report {
- my $self = shift;
- my @request_params = ();
-
- if(not defined $self->{api_key}) {
- croak "apikey required.";
- }
-
- while(@_) {
- my $attr = shift;
- my $value = shift;
-
- if ($attr eq "username" or $attr eq "ip_addr" or $attr eq "evidence" or $attr eq "email") {
- if (length($value) > 0) {
- push(@request_params, $attr . "=" . uri_escape($value));
- }
- }
- }
-
- # add default params
- push(@request_params, "api_key=" . $self->{api_key});
-
- my ($http_code, $buffer) = $self->_query_api(join("&", @request_params), 1);
-
- if (not defined $buffer) {
- return 0;
- }
-
- if ($http_code == 200) {
- return 1;
- } else {
- warn $self->_strip_tags($buffer);
- return 0;
- }
- }
- sub _query_api {
- my ($self, $data, $is_submit) = @_;
-
- if (not defined $is_submit) {
- $is_submit = 0;
- }
-
- my $buffer = "";
- my $curl = WWW::Curl::Easy->new();
-
- if ($is_submit) {
- $curl->setopt(CURLOPT_URL, "http://www.stopforumspam.com/add.php");
- $curl->setopt(CURLOPT_POST, 1);
- $curl->setopt(CURLOPT_POSTFIELDS, $data);
- } else {
- $curl->setopt(CURLOPT_URL, $self->{api_url} . "?" . $data);
- }
-
- $curl->setopt(CURLOPT_USERAGENT, "Mozilla/5.0 (compatible; WWW::StopForumSpam/0.1; +http://www.perlhipster.com/bot.html)");
- $curl->setopt(CURLOPT_ENCODING, "");
- $curl->setopt(CURLOPT_NOPROGRESS, 1);
- $curl->setopt(CURLOPT_FAILONERROR, 0);
- $curl->setopt(CURLOPT_TIMEOUT, $self->{timeout});
- $curl->setopt(CURLOPT_WRITEFUNCTION, sub {
- $buffer .= $_[0];
- return length($_[0]);
- });
-
- my $retcode = $curl->perform();
-
- if($retcode != 0) {
- warn $curl->errbuf;
- return;
- }
-
- return ($curl->getinfo(CURLINFO_HTTP_CODE), $buffer);
- }
- sub _get_avg_confidence {
- my ($self, $decoded_json) = @_;
- my $confidence_total = 0;
- my $confidence_num = 0;
-
- if(defined $decoded_json->{'username'}) {
- if (defined $decoded_json->{'username'}{'confidence'}) {
- $confidence_total += $decoded_json->{'username'}{'confidence'};
- }
- $confidence_num++;
- }
- if(defined $decoded_json->{'email'}) {
- if (defined $decoded_json->{'email'}{'confidence'}) {
- $confidence_total += $decoded_json->{'email'}{'confidence'};
- }
- $confidence_num++;
- }
- if(defined $decoded_json->{'ip'}) {
- if (defined $decoded_json->{'ip'}{'confidence'}) {
- $confidence_total += $decoded_json->{'ip'}{'confidence'};
- }
- $confidence_num++;
- }
-
- return $confidence_total / $confidence_num;
- }
- sub _ceil {
- my ($self, $num) = @_;
- return int($num) + ($num > int($num));
- }
- sub _strip_tags {
- my ($self, $string) = @_;
- while ($string =~ s/<\S[^<>]*(?:>|$)//gs) {};
- return $string;
- }
- 1;
- __END__
- =encoding utf8
- =head1 NAME
- WWW::StopForumSpam - Perl extension for the StopForumSpam.com API
- =head1 DESCRIPTION
- StopForumSpam is a Anti Spam Database for free usage. Even though aimed towards
- preventing registration of spambots on a forum, this extension can be used for
- any type of website (e.g. blog) as well.
- An API key is only needed for reporting a new case of spam registration.
- =head1 SYNOPSIS
- use WWW::StopForumSpam;
- my $sfs = WWW::StopForumSpam->new(
- api_key => "", # optional
- timeout => 4, # cURL timeout in seconds, defaults to 4
- treshold => 65, # defaults to 65
- );
-
- # Returns 1 if spammer (caution: it will return 1 also on errors, this is to
- # prevent mass spam registration due to services not working properly, you
- # should therefor always check logs)
- $sfs->check(
- ip => "127.0.0.1", # optional, recommended
- email => "test\@test.com", # optional, recommended
- username => "Foobar", # optional, not recommended
- );
-
- # Alternative api call via DNSBL. Does not support usernames.
- # Unlike check() this will NOT return 1 on server fail.
- $sfs->dns_check(
- ip => "127.0.0.1",
- email => "test\@test.com",
- );
-
- # Requires the setting of "api_key" in the constructor
- $sfs->report(
- username => "Foobar", # required
- ip_addr => "127.0.0.1", # required
- evidence => "", # optional (for example the forum-post)
- email => "test\@test.com", # required
- );
- );
- =head1 SEE ALSO
- API keys and more detail on StopForumSpam are available at L<http://www.stopforumspam.com>.
- Github: L<https://github.com/lifeofguenter/p5-stopforumspam>
- Website: L<http://www.perlhipster.com/p5-stopforumspam>
- DNSBL: L<http://sfs.dnsbl.st>
- =head1 AUTHOR
- Günter Grodotzki, E<lt>guenter@perlhipster.comE<gt>
- =head1 COPYRIGHT AND LICENSE
- Copyright (C) 2014 by Günter Grodotzki
- This module is free software; you can redistribute it and/or
- modify it under the same terms as Perl itself. See L<perlartistic>.
- =cut