File Coverage

blib/lib/PlugAuth/Client/Tiny.pm
Criterion Covered Total %
statement 42 48 87.5
branch 12 14 85.7
condition 4 5 80.0
subroutine 9 10 90.0
pod 5 5 100.0
total 72 82 87.8


line stmt bran cond sub pod time code
1             package PlugAuth::Client::Tiny;
2              
3 10     10   211364 use strict;
  10         44  
  10         224  
4 10     10   39 use warnings;
  10         13  
  10         179  
5 10     10   133 use 5.006;
  10         26  
6 10     10   2759 use HTTP::Tiny;
  10         191525  
  10         1632  
7              
8             # ABSTRACT: (Deprecated) Minimal PlugAuth client
9             our $VERSION = '0.03'; # VERSION
10              
11              
12             sub new
13             {
14 8     8 1 327 my $class = shift;
15 8 100       35 my %args = ref $_[0] ? %{$_[0]} : @_;
  1         5  
16 8   100     45 my $url = (delete $args{url}) || 'http://localhost:3000/';
17 8         52 $url =~ s{/?$}{/};
18 8         49 return bless {
19             url => $url,
20             http => HTTP::Tiny->new(%args),
21             }, $class;
22             }
23              
24              
25 3     3 1 1604 sub url { shift->{url} }
26              
27              
28             sub auth
29             {
30 3     3 1 25 my($self, $user, $password) = @_;
31            
32             my $response = $self->{http}->get($self->{url} . 'auth', {
33             headers => {
34             ## TODO option for setting the realm
35             # WWW-Authenticate: Basic realm="..."
36 3         11 Authorization => 'Basic ' . do {
37             ## TODO maybe use MIME::Base64 if available?
38             ## it is XS, but may be faster.
39 10     10   3839 use integer;
  10         108  
  10         46  
40 3         7 my $a = join(':', $user,$password);
41 3         12 my $r = pack('u', $a);
42 3         12 $r =~ s/^.//mg;
43 3         9 $r =~ s/\n//g;
44 3         7 $r =~ tr|` -_|AA-Za-z0-9+/|;
45 3         8 my $p = (3-length($a)%3)%3;
46 3 100       18 $r =~ s/.{$p}$/'=' x $p/e if $p;
  1         3  
47 3         19 $r;
48             },
49             }
50             });
51            
52 3 100       102 return 1 if $response->{status} == 200;
53             return 0 if $response->{status} == 403
54 2 100 66     12 || $response->{status} == 401;
55            
56 1         8 die $response->{content};
57             }
58              
59              
60             sub authz
61             {
62 4     4 1 23 my($self, $user, $action, $resource) = @_;
63            
64 4         14 $resource =~ s{^/?}{};
65 4         16 my $url = $self->{url} . join('/', 'authz', 'user', $user, $action, $resource);
66 4         11 my $response = $self->{http}->get($url);
67            
68 4 100       32 return 1 if $response->{status} == 200;
69 2 100       19 return 0 if $response->{status} == 403;
70 1         7 die $response->{content};
71             }
72              
73              
74             sub version
75             {
76 0     0 1   my($self) = @_;
77            
78 0           my $url = $self->{url} . 'version';
79 0           my $response = $self->{http}->get($url);
80            
81 0 0         return unless $response->{status} == 200;
82            
83             # JSON::PP is in core as of 5.14
84 0           require JSON::PP;
85 0           JSON::PP::decode_json($response->{content})->[0];
86             }
87              
88             1;
89              
90             __END__