File Coverage

blib/lib/Mojolicious/Plugin/BlogSpam.pm
Criterion Covered Total %
statement 68 191 35.6
branch 25 104 24.0
condition 9 62 14.5
subroutine 12 28 42.8
pod 1 1 100.0
total 115 386 29.7


line stmt bran cond sub pod time code
1             package Mojolicious::Plugin::BlogSpam;
2 1     1   802 use Mojo::Base 'Mojolicious::Plugin';
  1         3  
  1         6  
3 1     1   185 use Mojo::URL;
  1         9  
  1         8  
4 1     1   22 use Mojo::JSON;
  1         3  
  1         32  
5 1     1   5 use Mojo::Log;
  1         1  
  1         9  
6 1     1   33 use Mojo::UserAgent;
  1         2  
  1         8  
7 1     1   21 use Mojo::IOLoop;
  1         2  
  1         5  
8 1     1   32 use Scalar::Util 'weaken';
  1         2  
  1         596  
9              
10             our $VERSION = '0.11';
11              
12             # TODO: X-Forwarded-For in Config per index steuern
13             # TODO: - Check for blacklist/whitelist/max words etc. yourself.
14             # - Create a route condition for posts.
15             # -> $r->post('/comment')->over('blogspam')->to('#');
16              
17             our @OPTION_ARRAY =
18             qw/blacklist exclude whitelist mandatory
19             max-links max-size min-size min-words/;
20             # 'fail' is special, as it is boolean
21              
22              
23             # Register plugin
24             sub register {
25 1     1 1 35 my ($plugin, $mojo, $params) = @_;
26              
27 1   50     4 $params ||= {};
28              
29             # Load parameters from Config file
30 1 50       8 if (my $config_param = $mojo->config('BlogSpam')) {
31 0         0 $params = { %$config_param, %$params };
32             };
33              
34             # Set server url of BlogSpam instance
35             my $url = Mojo::URL->new(
36 1   50     25 delete $params->{url} || 'http://test.blogspam.net/'
37             );
38              
39             # Set port of BlogSpam instance
40 1   50     175 $url->port(delete $params->{port} || '8888');
41              
42             # Site name
43 1         5 my $site = delete $params->{site};
44              
45             # Add Log
46 1         2 my $log;
47 1 50       3 if (my $log_path = delete $params->{log}) {
48             $log = Mojo::Log->new(
49             path => $log_path,
50 0   0     0 level => delete $params->{log_level} || 'info'
51             );
52             };
53              
54 1         6 my $app_log_clone = $mojo->log;
55 1         174 weaken $app_log_clone;
56              
57             # Get option defaults
58 1         2 my (%options, $base_options);
59 1         2 foreach ('fail', @OPTION_ARRAY) {
60 9 100       21 $options{$_} = delete $params->{$_} if $params->{$_};
61             };
62 1 50       3 $base_options = \%options if %options;
63              
64              
65             # Add 'blogspam' helper
66             $mojo->helper(
67             blogspam => sub {
68 4     4   4998 my $c = shift;
69              
70             # Create new BlogSpam::Comment object
71 4         15 my $obj = Mojolicious::Plugin::BlogSpam::Comment->new(
72             url => $url->to_string,
73             log => $log,
74             site => $site,
75             app_log => $app_log_clone,
76             client => __PACKAGE__ . ' v' . $VERSION,
77             base_options => $base_options,
78             @_
79             );
80              
81             # Get request headers
82 4         1116 my $headers = $c->req->headers;
83              
84             # Set user-agent if not given
85 4 100       193 $obj->agent($headers->user_agent) unless $obj->agent;
86              
87             # No ip manually given
88 4 100       61 unless ($obj->ip) {
89              
90             # Get forwarded ip
91 3 100       16 if (my $ip = $headers->to_hash->{'X-Forwarded-For'}) {
92 1         45 $obj->ip( split(/\s*,\s*/, $ip) );
93             };
94              
95             # Get host ip, because X-Forwarded-For wasn't set
96 3 100       63 unless ($obj->ip) {
97 2   100     11 $obj->ip( split(/\s*:\s*/, ($headers->host || '')) );
98             };
99             };
100              
101             # Return blogspam object
102 4         57 return $obj;
103             }
104 1         9 );
105             };
106              
107              
108             # BlogSpam object class
109             package Mojolicious::Plugin::BlogSpam::Comment;
110 1     1   6 use Mojo::Base -base;
  1         2  
  1         4  
111              
112              
113             # Attributes
114             has [qw/comment ip email link name subject agent/];
115              
116              
117             # Test comment for spam
118             sub test_comment {
119 0     0   0 my $self = shift;
120              
121             # Callback for async
122 0 0 0     0 my $cb = pop if $_[-1] && ref $_[-1] && ref $_[-1] eq 'CODE';
      0        
123              
124             # No IP or comment text defined
125 0 0 0     0 unless ($self->ip && $self->comment) {
126 0         0 $self->{app_log}->debug('You have to specify ip and comment');
127 0         0 return;
128             };
129              
130             # Create option string
131 0         0 my $option_string = $self->_options(@_);
132              
133             # Check for mandatory parameters
134 0   0     0 while ($option_string &&
135             $option_string =~ m/(?:^|,)mandatory=([^,]+?)(?:,|$)/g) {
136 0 0       0 return unless $self->{$1};
137             };
138              
139             # Create option array if set
140 0 0       0 my @options = (options => $option_string) if $option_string;
141              
142             # Push site to array if set
143 0 0       0 push(@options, site => $self->{site}) if $self->{site};
144              
145             # Make xml-rpc call
146 0 0       0 if ($cb) {
147              
148             # Make call non-blocking
149             $self->_xml_rpc_call(
150             testComment => (
151 0         0 %{$self->hash},
152             @options
153             ) => sub {
154              
155             # Analyze response
156 0     0   0 return $cb->( $self->_handle_test_response( shift ) );
157             }
158 0         0 );
159              
160             # Do not use this value
161 0         0 return -1;
162             };
163              
164             # Make call blocking
165             my $res = $self->_xml_rpc_call(
166             testComment => (
167 0         0 %{$self->hash},
  0         0  
168             @options
169             )
170             );
171              
172             # Analyze response
173 0         0 return $self->_handle_test_response($res);
174             };
175              
176              
177             # Classify a comment as spam or ham
178             sub classify_comment {
179 0     0   0 my $self = shift;
180 0         0 my $train = lc shift;
181              
182             # Callback for async
183 0 0 0     0 my $cb = pop if $_[-1] && ref $_[-1] && ref $_[-1] eq 'CODE';
      0        
184              
185             # Missing comment and valid train option
186 0 0 0     0 unless ($self->comment && $train && $train =~ /^(?:ok|spam)$/) {
      0        
187 0         0 $self->{app_log}->debug('You have to specify comment and train value');
188 0         0 return;
189             };
190              
191             # Create site array if set
192 0 0       0 my @site = (site => $self->{site}) if $self->{site};
193              
194             # Send xml-rpc call
195 0 0       0 if ($cb) {
196              
197             # Non-blocking request
198             $self->_xml_rpc_call(classifyComment => (
199 0         0 %{$self->hash},
200             train => $train,
201             @site,
202             sub {
203 0     0   0 my $res = shift;
204 0 0       0 $cb->($res ? 1 : 0);
205             }
206 0         0 ));
207              
208 0         0 return;
209             };
210              
211             # Blocking request
212             return 1 if $self->_xml_rpc_call(classifyComment => (
213 0 0       0 %{$self->hash},
  0         0  
214             train => $train,
215             @site
216             ));
217              
218 0         0 return;
219             };
220              
221              
222             # Get a list of plugins installed at the BlogSpam instance
223             sub get_plugins {
224 0     0   0 my $self = shift;
225              
226             # Callback for async
227 0 0 0     0 my $cb = pop if $_[-1] && ref $_[-1] && ref $_[-1] eq 'CODE';
      0        
228              
229             # Response of xml-rpc call
230 0 0       0 if ($cb) {
231              
232             # Non-blocking request
233             $self->_xml_rpc_call(
234             getPlugins => sub {
235 0     0   0 my $res = shift;
236              
237             # Analyze response in callback
238 0         0 return $cb->($self->_handle_plugins_response($res));
239 0         0 });
240              
241 0         0 return ();
242             };
243              
244             # Blocking request
245 0         0 my $res = $self->_xml_rpc_call('getPlugins');
246              
247             # Analyze response
248 0         0 return $self->_handle_plugins_response($res);
249             };
250              
251              
252             # Get statistics of your site from the BlogSpam instance
253             sub get_stats {
254 0     0   0 my $self = shift;
255              
256             # Callback for async
257 0 0 0     0 my $cb = pop if $_[-1] && ref $_[-1] && ref $_[-1] eq 'CODE';
      0        
258              
259 0   0     0 my $site = shift || $self->{site};
260              
261             # No site is given
262 0 0       0 return unless $site;
263              
264             # Send xml-rpc call
265 0 0       0 if ($cb) {
266              
267             # Send non-blocking request
268             my $res = $self->_xml_rpc_call(
269             'getStats', $site => sub {
270 0     0   0 my $res = shift;
271 0         0 return $cb->($self->_handle_stats_response($res));
272 0         0 });
273              
274 0         0 return;
275             };
276              
277             # Send blocking request
278 0         0 my $res = $self->_xml_rpc_call('getStats', $site);
279 0         0 return $self->_handle_stats_response($res);
280             };
281              
282              
283             # Get a hash representation of the comment
284             sub hash {
285 1     1   30 my $self = shift;
286 1         9 my %hash = %$self;
287              
288             # Delete non-comment info
289 1         5 delete @hash{qw/site app_log url log client base_options/};
290              
291             # Delete empty values
292 1         3 return { map {$_ => $hash{$_} } grep { $hash{$_} } keys %hash };
  7         21  
  7         11  
293             };
294              
295              
296             # Handle test_comment response
297             sub _handle_test_response {
298 0     0   0 my ($self, $res) = @_;
299              
300             # No response
301 0 0       0 return -1 unless $res;
302              
303             # Get response element
304 0         0 my $response =
305             $res->dom->at('methodResponse > params > param > value > string');
306              
307             # Unexpected response format
308 0 0       0 return -1 unless $response;
309              
310             # Get response tag
311 0         0 $response = $response->all_text;
312              
313             # Response string is malformed
314 0 0       0 return -1 unless $response =~ /^(OK|ERROR|SPAM)(?:\:\s*(.+?))?$/;
315              
316             # Comment is no spam
317 0 0       0 return 1 if $1 eq 'OK';
318              
319             # Log is defined
320 0 0       0 if (my $log = $self->{log}) {
321              
322             # Serialize comment
323 0   0     0 my $msg = "[$1]: " . ($2 || '') . ' ' .
324             Mojo::JSON->new->encode($self->hash);
325              
326             # Log error
327 0 0       0 if ($1 eq 'ERROR') {
328 0         0 $log->error($msg);
329             }
330              
331             # Log spam
332             else {
333 0         0 $log->info($msg);
334             };
335             };
336              
337             # An error occured
338 0 0       0 return -1 if $1 eq 'ERROR';
339              
340             # The comment is considered spam
341 0         0 return 0;
342             };
343              
344              
345             # Handle get_plugins response
346             sub _handle_plugins_response {
347 0     0   0 my ($self, $res) = @_;
348              
349             # Retrieve result
350 0         0 my $array =
351             $res->dom->at('methodResponse > params > param > value > array > data');
352              
353             # No plugins installed
354 0 0       0 return () unless $array;
355              
356             # Convert data to array
357 0     0   0 return @{$array->find('string')->map(sub { $_->text })};
  0         0  
  0         0  
358             };
359              
360              
361             # Handle get_stats response
362             sub _handle_stats_response {
363 0     0   0 my ($self, $res) = @_;
364              
365             # Get response struct
366 0         0 my $hash =
367             $res->dom->at('methodResponse > params > param > value > struct');
368              
369             # No response struct defined
370 0 0       0 return +{} unless $hash;
371              
372             # Convert struct to hash
373 0         0 return {@{$hash->find('member')->map(
374             sub {
375 0     0   0 return ($_->at('name')->text, $_->at('value > int')->text);
376 0         0 })}};
377             };
378              
379              
380             # Get options string
381             sub _options {
382 1     1   458 my $self = shift;
383 1         3 my %options = @_;
384              
385             # Create option string
386 1         2 my @options;
387 1 50 33     4 if (%options || $self->{base_options}) {
388              
389             # Get base options from plugin registration
390 1         2 my $base = $self->{base_options};
391              
392             # Check for fail flag
393 1 50       5 if (exists $options{fail}) {
    50          
394 0 0       0 push(@options, 'fail') if $options{fail};
395             }
396              
397             # Check for fail flag in plugin defaults
398             elsif ($base->{fail}) {
399 0         0 push(@options, 'fail');
400             };
401              
402             # Check for valid option parameters
403 1         3 foreach my $n (@Mojolicious::Plugin::BlogSpam::OPTION_ARRAY) {
404              
405             # Option flag is not set
406 8 100 100     26 next unless $options{$n} || $base->{$n};
407              
408             # Base options
409             my $opt = [
410 2 100       6 $base->{$n} ? (ref $base->{$n} ? @{$base->{$n}} : $base->{$n}) : ()
  1 50       3  
411             ];
412              
413             # Push new options
414             push(
415             @$opt,
416 2 50       6 $options{$n} ? (ref $options{$n} ? @{$options{$_}} : $options{$n}) : ()
  0 100       0  
417             );
418              
419             # Option flag is set as an array
420 2         8 push(@options, "$n=$_") foreach @$opt};
421             };
422              
423             # return option string
424 1 50       6 return join(',', @options) if @options;
425              
426 0           return;
427             };
428              
429              
430             # Send xml-rpc call
431             sub _xml_rpc_call {
432 0     0     my $self = shift;
433              
434             # Callback for async
435 0 0 0       my $cb = pop if ref $_[-1] && ref $_[-1] eq 'CODE';
436              
437 0           my ($method_name, $param) = @_;
438              
439             # Create user agent
440             my $ua = Mojo::UserAgent->new(
441             max_redirects => 3,
442             name => $self->{client}
443 0           );
444              
445             # Start xml document
446 0           my $xml = '' .
447             "\n$method_name";
448              
449             # Send with params
450 0 0         if ($param) {
451 0           $xml .= '';
452              
453             # Param is a struct
454 0 0         if (ref $param) {
455 0           $xml .= '';
456              
457             # Create struct object
458 0           foreach (keys %$param) {
459             $xml .= "$_" .
460             '' . $param->{$_} . '' .
461 0 0         "\n" if $param->{$_};
462             };
463              
464             # End struct
465 0           $xml .= '';
466             }
467              
468             # Param is a string
469             else {
470 0           $xml .= "$param";
471             };
472              
473             # End parameter list
474 0           $xml .= '';
475             };
476              
477             # End method call
478 0           $xml .= '';
479              
480             # Post method call to BlogSpam instance
481 0 0         if ($cb) {
482              
483             # Create delay object
484             my $delay = Mojo::IOLoop->delay(
485             sub {
486 0     0     my $tx = pop;
487              
488 0           my $res = $tx->success;
489              
490             # Connection failure - accept comment
491 0 0         unless ($res) {
492             # Maybe there needs something to be weakened
493 0           $self->_log_error($tx);
494 0           return;
495             };
496              
497             # Send response to callback
498 0           $cb->($res);
499             }
500 0           );
501              
502             # Post non-blocking
503 0           $ua->post($self->{url} => +{} => $xml => $delay->begin);
504              
505             # Start IOLoop if not started already
506 0 0         $delay->wait unless Mojo::IOLoop->is_running;
507              
508 0           return;
509             };
510              
511             # Post blocking
512 0           my $tx = $ua->post($self->{url} => +{} => $xml);
513 0           my $res = $tx->success;
514              
515             # Connection failure - accept comment
516 0 0         unless ($res) {
517 0           $self->_log_error($tx);
518 0           return;
519             };
520              
521             # Return response
522 0           return $res;
523             };
524              
525              
526             # Log connection_error
527             sub _log_error {
528 0     0     my ($self, $tx) = @_;
529              
530 0           my ($err, $code) = $tx->error;
531 0   0       $code ||= '*';
532              
533             $self->{app_log}->warn(
534             "Connection error: [$code] $err for " .
535             $self->{url}
536 0           );
537              
538 0           return;
539             };
540              
541              
542             1;
543              
544              
545             __END__