File Coverage

blib/lib/App/SpamcupNG/UserAgent.pm
Criterion Covered Total %
statement 51 131 38.9
branch 4 42 9.5
condition 0 5 0.0
subroutine 14 19 73.6
pod 6 6 100.0
total 75 203 36.9


line stmt bran cond sub pod time code
1             use warnings;
2 6     6   94101 use strict;
  6         16  
  6         160  
3 6     6   25 use Carp qw(croak);
  6         9  
  6         108  
4 6     6   22 use LWP::UserAgent 6.60;
  6         9  
  6         272  
5 6     6   2971 use HTTP::Request 6.36;
  6         183197  
  6         183  
6 6     6   47 use Log::Log4perl 1.54 qw(get_logger :levels);
  6         83  
  6         149  
7 6     6   610 use HTTP::CookieJar::LWP 0.012;
  6         32188  
  6         38  
8 6     6   2945 use Mozilla::PublicSuffix v1.0.6;
  6         126860  
  6         203  
9 6     6   62 use HTTP::Request::Common qw(POST);
  6         72  
  6         268  
10 6     6   2474  
  6         9823  
  6         6309  
11             our $VERSION = '0.015'; # VERSION
12              
13             =head1 NAME
14              
15             App::SpamcupNG::UserAgent - the SpamcupNG HTTP user agent
16              
17             =head1 SYNOPSIS
18              
19             =head1 DESCRIPTION
20              
21             This class is responsible to interact with the Spamcop website, providing
22             requests and returning the HTML responses.
23              
24             =head1 METHODS
25              
26             =head2 new
27              
28             Creates a new instance.
29              
30             Expects as parameter:
31              
32             - version: a string of the version of SpamcupNG.
33              
34             Returns a new instance.
35              
36             =cut
37              
38             my ( $class, $version ) = @_;
39             die 'The parameter version is required' unless ($version);
40 2     2 1 734  
41 2 100       13 my $self = {
42             name => 'SpamcupNG user agent',
43 1         10 version => $version,
44             members_url => 'https://members.spamcop.net/',
45             code_login_url => 'https://www.spamcop.net/?code=',
46             report_url => 'https://www.spamcop.net/sc?id=',
47             form_login_url => 'https://www.spamcop.net/mcgi',
48             domain => 'https://www.spamcop.net/',
49             password_field => 'password',
50             current_base_url => undef
51             };
52              
53             bless $self, $class;
54              
55 1         3 my $ua = LWP::UserAgent->new(
56             agent => ( $self->{name} . '/' . $version ),
57             protocols_allowed => ['https'],
58 1         17 cookie_jar => HTTP::CookieJar::LWP->new
59             );
60              
61             # for form based authentication
62             push @{ $ua->requests_redirectable }, 'POST';
63             $self->{user_agent} = $ua;
64 1         2276 return $self;
  1         4  
65 1         11 }
66 1         6  
67             =head2 user_agent
68              
69             Returns a string with the HTTP header user-agent that will be used by the inner
70             HTTP user agent.
71              
72             =cut
73              
74             my $self = shift;
75             return $self->{user_agent}->agent;
76             }
77 1     1 1 3  
78 1         3 =head2 login
79              
80             Execute the login to Spamcop website.
81              
82             If form based authentication is in use, it will login just once and return the
83             response of HTTP GET to Spamcop root URL.
84              
85             Expect as parameters:
86              
87             =over
88              
89             =item *
90              
91             id: the ID of a Spamcop account.
92              
93             =item *
94              
95             password: the password of a Spamcop account.
96              
97             =back
98              
99             Returns the HTTP response (HTML content) as a scalar reference.
100              
101             =cut
102              
103             # copied from HTTP::Request::as_string
104             my $request = shift;
105             my $req_line = $request->method || "-";
106             my $uri = $request->uri;
107             $uri = ( defined $uri ) ? $uri->as_string : "-";
108 0     0   0 $req_line .= " $uri";
109 0   0     0 my $proto = $request->protocol;
110 0         0 $req_line .= " $proto" if $proto;
111 0 0       0 return $req_line;
112 0         0 }
113 0         0  
114 0 0       0 my ( $self, $request ) = @_;
115 0         0 my @lines;
116              
117             return $request->as_string if ( $self->_is_authenticated );
118              
119 1     1   7087 if ( $request->method eq 'POST' ) {
120 1         2 push( @lines, _request_line($request) );
121             push( @lines, $request->headers_as_string );
122 1 50       3 my @params = split( '&', $request->content );
123             my %params
124 1 50       72 = map { my @tmp = split( '=', $_ ); $tmp[0] => $tmp[1] } @params;
125 0         0 croak( 'Unexpected request content, missing '
126 0         0 . $self->{password_field}
127 0         0 . ' field' )
128             unless exists( $params{ $self->{password_field} } );
129 0         0 my $redacted = '*' x length( $params{ $self->{password_field} } );
  0         0  
  0         0  
130             $params{ $self->{password_field} } = $redacted;
131              
132             while ( my ( $key, $value ) = each %params ) {
133 0 0       0 push( @lines, "$key=$value" );
134 0         0 }
135 0         0 }
136             else {
137 0         0 @lines = split( "\n", $request->as_string );
138 0         0 my $secret = ( split( /\s/, $lines[1] ) )[2];
139             my $redacted = '*' x length($secret);
140             $lines[1] =~ s/$secret/$redacted/;
141             }
142 1         15  
143 1         155 return join( "\n", @lines );
144 1         4 }
145 1         12  
146             my $self = shift;
147             my @cookies = $self->{user_agent}
148 1         7 ->cookie_jar->dump_cookies( { persistent => 1 } );
149             my $counter = 0;
150             my @dump;
151              
152 0     0   0 foreach my $cookie (@cookies) {
153             push( @dump, ( $counter . ' => ' . $cookie ) );
154 0         0 }
155 0         0  
156 0         0 return join( "\n", @dump );
157             }
158 0         0  
159 0         0 my $self = shift;
160             return $self->{user_agent}->cookie_jar->cookies_for( $self->{domain} );
161             }
162 0         0  
163             my ( $self, $id, $password, $is_basic ) = @_;
164             $is_basic = 0 unless ( defined($is_basic) );
165             my $logger = get_logger('SpamcupNG');
166 1     1   2 my $request;
167 1         6  
168             if ( $logger->is_debug ) {
169             $logger->debug( "Initial cookies:\n" . $self->_dump_cookies );
170             }
171 0     0 1 0  
172 0 0       0 if ( $self->_is_authenticated ) {
173 0         0 $logger->info('Already authenticated');
174 0         0 $request = HTTP::Request->new( GET => $self->{domain} );
175             }
176 0 0       0 else {
177 0         0 if ($password) {
178              
179             if ($is_basic) {
180 0 0       0 $request = HTTP::Request->new( GET => $self->{members_url} );
181 0         0 $request->authorization_basic( $id, $password );
182 0         0 }
183             else {
184             $request = POST $self->{form_login_url},
185 0 0       0 [
186             username => $id,
187 0 0       0 $self->{password_field} => $password,
188 0         0 duration => '+12h',
189 0         0 action => 'cookielogin',
190             returnurl => '/'
191             ];
192             }
193             }
194             else {
195 0         0 $request
196             = HTTP::Request->new( GET => $self->{code_login_url} . $id );
197             }
198             }
199              
200             $request->protocol('HTTP/1.1');
201              
202             if ( $logger->is_debug() ) {
203             $logger->debug(
204 0         0 "Request details:\n" . ( $self->_redact_auth_req($request) ) );
205             }
206              
207             my $response = $self->{user_agent}->request($request);
208 0         0  
209             if ( $logger->is_debug() ) {
210 0 0       0 $logger->debug( "Got response:\n" . $response->as_string );
211 0         0 $logger->debug(
212             "After authentication cookies:\n" . $self->_dump_cookies );
213             }
214              
215 0         0 return \( $response->content ) if ( $response->is_success );
216              
217 0 0       0 my $status = $response->status_line();
218 0         0  
219 0         0 if ( $response->code() == 500 ) {
220             $logger->fatal("Can\'t connect to server: $status");
221             }
222             else {
223 0 0       0 $logger->warn($status);
224              
225 0         0 if ( ($password) and ( $is_basic == 0 ) ) {
226             $logger->warn('Retrying with basic authentication');
227 0 0       0 return $self->login( $id, $password, 1 );
228 0         0 }
229              
230             $logger->fatal(
231 0         0 'Cannot connect to server or invalid credentials. Please verify your username and password and try again.'
232             );
233 0 0 0     0 }
234 0         0  
235 0         0 return undef;
236             }
237              
238             =head2 spam_report
239 0         0  
240             Fetches a SPAM report.
241              
242             Expects as parameter a report ID.
243 0         0  
244             Returns the HTML content as a scalar reference.
245              
246             =cut
247              
248             my ( $self, $report_id ) = @_;
249             my $logger = get_logger('SpamcupNG');
250             my $request
251             = HTTP::Request->new( GET => $self->{report_url} . $report_id );
252              
253             if ( $logger->is_debug ) {
254             $logger->debug( "Request to be sent:\n" . $request->as_string );
255             }
256              
257 0     0 1 0 my $response = $self->{user_agent}->request($request);
258 0         0 $self->{current_base_url} = $response->base;
259              
260 0         0 if ( $logger->is_debug ) {
261             $logger->debug( "Got HTTP response:\n" . $response->as_string );
262 0 0       0 }
263 0         0  
264             unless ( $response->is_success ) {
265             $logger->fatal("Can't connect to server. Try again later.");
266 0         0 return undef;
267 0         0 }
268              
269 0 0       0 return \( $response->content );
270 0         0 }
271              
272             =head2 base
273 0 0       0  
274 0         0 Returns the current base URL provided by the last response of getting a SPAM
275 0         0 report.
276              
277             =cut
278 0         0  
279             my $self = shift;
280             return $self->{current_base_url};
281             }
282              
283             =head2 complete_report
284              
285             Complete the SPAM report, by confirming it's information is OK.
286              
287             Returns the HTML content as a scalar reference.
288              
289 1     1 1 2944 =cut
290 1         5  
291             my ( $self, $http_request ) = @_;
292             my $logger = get_logger('SpamcupNG');
293             my $response = $self->{user_agent}->request($http_request);
294              
295             if ( $logger->is_debug ) {
296             $logger->debug( "Got HTTP response:\n" . $response->as_string );
297             }
298              
299             unless ( $response->is_success ) {
300             $logger->fatal(
301             'Cannot connect to server. Try again later. Quitting.');
302 0     0 1   return undef;
303 0           }
304 0            
305             return \( $response->content );
306 0 0         }
307 0            
308             =head1 AUTHOR
309              
310 0 0         Alceu Rodrigues de Freitas Junior, E<lt>arfreitas@cpan.orgE<gt>
311 0            
312             =head1 COPYRIGHT AND LICENSE
313 0            
314             This software is copyright (c) 2018 of Alceu Rodrigues de Freitas Junior,
315             E<lt>arfreitas@cpan.orgE<gt>
316 0            
317             This file is part of App-SpamcupNG distribution.
318              
319             App-SpamcupNG is free software: you can redistribute it and/or modify it under
320             the terms of the GNU General Public License as published by the Free Software
321             Foundation, either version 3 of the License, or (at your option) any later
322             version.
323              
324             App-SpamcupNG is distributed in the hope that it will be useful, but WITHOUT
325             ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
326             FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
327              
328             You should have received a copy of the GNU General Public License along with
329             App-SpamcupNG. If not, see <http://www.gnu.org/licenses/>.
330              
331             =cut
332              
333             1;