File Coverage

blib/lib/Authen/Simple/HTTP.pm
Criterion Covered Total %
statement 27 55 49.0
branch 0 18 0.0
condition n/a
subroutine 9 12 75.0
pod 1 1 100.0
total 37 86 43.0


line stmt bran cond sub pod time code
1             package Authen::Simple::HTTP;
2              
3 1     1   1209 use strict;
  1         2  
  1         42  
4 1     1   6 use warnings;
  1         3  
  1         38  
5 1     1   15 use base 'Authen::Simple::Adapter';
  1         2  
  1         1375  
6              
7 1     1   116241 use LWP::UserAgent;
  1         147741  
  1         48  
8 1     1   14 use Params::Validate qw[];
  1         2  
  1         176  
9              
10             our $VERSION = 0.2;
11              
12             __PACKAGE__->options({
13             url => {
14             type => Params::Validate::SCALAR,
15             optional => 0
16             },
17             agent => {
18             type => Params::Validate::OBJECT,
19             isa => 'LWP::UserAgent',
20             default => LWP::UserAgent->new(
21             cookie_jar => {},
22             keep_alive => 1,
23             timeout => 30
24             ),
25             optional => 1
26             }
27             });
28              
29             sub check {
30 0     0 1   my ( $self, $username, $password ) = @_;
31              
32             # This implementation is very hackish, however I could not find a cleaner
33             # way to implement this without forking a lot of code from LWP::UserAgent.
34             # Please let me know if you have any ideas of improvements.
35              
36 0           my $override = sprintf '%s::get_basic_credentials', ref $self->agent;
37 0           my $response = undef;
38 0           my $url = $self->url;
39              
40             # First make sure we receive a challenge
41              
42             {
43 1     1   6 no strict 'refs';
  1         4  
  1         1913  
  0            
44 1     1   13 no warnings 'redefine';
  1         3  
  1         277  
45              
46             local *$override = sub {
47 0     0     return ( undef, undef );
48 0           };
49              
50 0           $response = $self->agent->head($url);
51             }
52              
53 0 0         if ( my $warning = $response->header('Client-Warning') ) {
54              
55 0 0         $self->log->error( qq/Received a client warning: '$warning'./ )
56             if $self->log;
57              
58 0           return 0;
59             }
60              
61 0 0         if ( $response->code != 401 ) {
62              
63 0 0         $self->log->error( qq/Server did not return a authentication challenge for '$url'./ )
64             if $self->log;
65              
66 0           return 0;
67             }
68              
69             # We have a challenge, issue a new request with credentials.
70              
71             {
72 1     1   7 no strict 'refs';
  1         3  
  1         34  
  0            
73 1     1   6 no warnings 'redefine';
  1         1  
  1         323  
74              
75             local *$override = sub {
76 0     0     return ( $username, $password );
77 0           };
78              
79 0           $response = $self->agent->head($url);
80             }
81              
82 0 0         if ( $response->code == 401 ) {
83              
84 0 0         $self->log->debug( qq/Failed to authenticate user '$username' using url '$url'. Reason: 'Invalid credentials'/ )
85             if $self->log;
86              
87 0           return 0;
88             }
89              
90 0 0         if ( $response->is_error ) {
91              
92 0           my $code = $response->code;
93 0           my $message = $response->message;
94              
95 0 0         $self->log->error( qq/Failed to authenticate user '$username' using url '$url'. Reason: '$code $message'/ )
96             if $self->log;
97              
98 0           return 0;
99             }
100              
101 0 0         $self->log->debug( qq/Successfully authenticated user '$username' using url '$url'./ )
102             if $self->log;
103              
104 0           return 1;
105             }
106              
107             1;
108              
109             __END__