view release on metacpan or  search on metacpan

lib/Mojolicious/Plugin/BlogSpam.pm  view on Meta::CPAN

package Mojolicious::Plugin::BlogSpam;
use Mojo::Base 'Mojolicious::Plugin';
use Mojo::URL;
use Mojo::JSON;
use Mojo::Log;
use Mojo::UserAgent;
use Mojo::IOLoop;
use Scalar::Util 'weaken';

our $VERSION = '0.12';

# TODO: X-Forwarded-For in Config per index steuern
# TODO: - Check for blacklist/whitelist/max words etc. yourself.
#       - Create a route condition for posts.
#         -> $r->post('/comment')->over('blogspam')->to('#');

our @OPTION_ARRAY =
  qw/blacklist exclude whitelist mandatory
     max-links max-size min-size min-words/;
     # 'fail' is special, as it is boolean


# Register plugin
sub register {
  my ($plugin, $mojo, $params) = @_;

  $params ||= {};

  # Load parameters from Config file
  if (my $config_param = $mojo->config('BlogSpam')) {
    $params = { %$config_param, %$params };
  };

  # Set server url of BlogSpam instance
  my $url = Mojo::URL->new(
    delete $params->{url} || 'http://test.blogspam.net/'
  );

  # Set port of BlogSpam instance
  $url->port(delete $params->{port} || '8888');

  # Site name
  my $site = delete $params->{site};

  # Add Log
  my $log;
  if (my $log_path = delete $params->{log}) {
    $log = Mojo::Log->new(
      path  => $log_path,
      level => delete $params->{log_level} || 'info'
    );
  };

  my $app_log_clone = $mojo->log;
  weaken $app_log_clone;

  # Get option defaults
  my (%options, $base_options);
  foreach ('fail', @OPTION_ARRAY) {
    $options{$_} = delete $params->{$_} if $params->{$_};
  };
  $base_options = \%options if %options;


  # Add 'blogspam' helper
  $mojo->helper(
    blogspam => sub {
      my $c = shift;

      # Create new BlogSpam::Comment object
      my $obj = Mojolicious::Plugin::BlogSpam::Comment->new(
        url     => $url->to_string,
        log     => $log,
        site    => $site,
        app_log => $app_log_clone,
        client  => __PACKAGE__ . ' v' . $VERSION,
        base_options => $base_options,
        @_
      );

      # Get request headers
      my $headers = $c->req->headers;

      # Set user-agent if not given
      $obj->agent($headers->user_agent) unless $obj->agent;

      # No ip manually given
      unless ($obj->ip) {

        # Get forwarded ip
        if (my $ip = $headers->to_hash->{'X-Forwarded-For'}) {
          $obj->ip( split(/\s*,\s*/, $ip) );
        };

        # Get host ip, because X-Forwarded-For wasn't set
        unless ($obj->ip) {
          $obj->ip( split(/\s*:\s*/, ($headers->host || '')) );
        };
      };

      # Return blogspam object
      return $obj;
    }
  );
};


# BlogSpam object class
package Mojolicious::Plugin::BlogSpam::Comment;
use Mojo::Base -base;


# Attributes
has [qw/comment ip email link name subject agent/];


# Test comment for spam
sub test_comment {
  my $self = shift;

  # Callback for async
  my $cb = pop if $_[-1] && ref $_[-1] && ref $_[-1] eq 'CODE';

  # No IP or comment text defined
  unless ($self->ip && $self->comment) {
    $self->{app_log}->debug('You have to specify ip and comment');
    return;
  };

  # Create option string
  my $option_string = $self->_options(@_);

  # Check for mandatory parameters
  while ($option_string &&
     $option_string =~ m/(?:^|,)mandatory=([^,]+?)(?:,|$)/g) {
    return unless $self->{$1};
  };

  # Create option array if set
  my @options = (options => $option_string) if $option_string;

  # Push site to array if set
  push(@options, site => $self->{site}) if $self->{site};

  # Make xml-rpc call
  if ($cb) {

    # Make call non-blocking
    $self->_xml_rpc_call(
      testComment => (
        %{$self->hash},
        @options
      ) => sub {

        # Analyze response

lib/Mojolicious/Plugin/BlogSpam.pm  view on Meta::CPAN

See L</"test_comment"> method below.


=head1 HELPERS

=head2 blogspam

  # In controller:
  my $bs = $c->blogspam(
    comment => 'This is a comment to test the system',
    name => 'Akron'
  );

Returns a new blogspam object, based on the given attributes.


=head1 OBJECT ATTRIBUTES

These attributes are primarily based on
the L<BlogSpam API|http://blogspam.net/api>.

=head2 agent

  $bs->agent('Mozilla/5.0 (X11; Linux x86_64; rv:12.0) ...');
  my $agent = $bs->agent;

The user-agent sending the comment.
Defaults to the user-agent of the request.


=head2 comment

  $bs->comment('This is just a test comment');
  my $comment_text = $bs->comment;

The comment text.


=head2 email

  $bs->email('spammer@sojolicious.example');
  my $email = $bs->email;

The email address of the commenter.


=head2 hash

  my $hash = $bs->hash;

Returns a hash representation of the comment.


=head2 ip

  $bs->ip('192.168.0.1');
  my $ip = $bs->ip;

The ip address of the commenter.
Defaults to the ip address of the request.
Supports C<X-Forwarded-For> proxy information.


=head2 link

  $bs->link('http://grimms-abenteuer.de/');
  my $link = $bs->link;

Homepage link given by the commenter.


=head2 name

  $bs->name('Akron');
  my $name = $bs->name;

Name given by the commenter.


=head2 subject

  $bs->subject('Fun');
  my $subject = $bs->subject;

Subject given by the commenter.


=head1 OBJECT METHODS

These methods are based on the L<BlogSpam API|http://blogspam.net/api>.

=head2 test_comment

  # Blocking
  if ($bs->test_comment(
         mandatory => 'name',
         blacklist => ['192.168.0.1']
      )) {
    print 'Probably ham!';
  } else {
    print 'Spam!';
  };

  # Non-blocking
  $bs->test_comment(
    mandatory => 'name',
    blacklist => ['192.168.0.1'],
    sub {
      my $result = shift;
      print ($result ? 'Probably ham!' : 'Spam!');
    }
  );

Test the comment of the blogspam object for spam or ham.
It's necessary to have a defined comment text and an IP address.
The method returns nothing in case the comment is detected
as spam, C<1> if the comment is detected as ham and C<-1>
if something went horribly, horribly wrong.
Accepts additional option parameters as defined in the
L<BlogSpam API|http://blogspam.net/api>.