File Coverage

lib/Net/OAuth2/Profile.pm
Criterion Covered Total %
statement 122 170 71.7
branch 24 50 48.0
condition 21 63 33.3
subroutine 29 41 70.7
pod 16 30 53.3
total 212 354 59.8


line stmt bran cond sub pod time code
1             # Copyrights 2013-2019 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Net-OAuth2. Meta-POD processed
6             # with OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Net::OAuth2::Profile;
10 4     4   27 use vars '$VERSION';
  4         7  
  4         157  
11             $VERSION = '0.66';
12              
13              
14 4     4   18 use warnings;
  4         6  
  4         89  
15 4     4   15 use strict;
  4         6  
  4         73  
16              
17 4     4   1618 use LWP::UserAgent ();
  4         114277  
  4         79  
18 4     4   44 use URI ();
  4         11  
  4         67  
19 4     4   452 use JSON::MaybeXS qw/decode_json/;
  4         5003  
  4         245  
20 4     4   31 use Carp qw/confess carp/;
  4         9  
  4         165  
21 4     4   21 use Scalar::Util qw/blessed/;
  4         5  
  4         145  
22 4     4   2113 use Encode qw/encode/;
  4         38558  
  4         242  
23              
24 4     4   25 use constant MIME_URLENC => 'application/x-www-form-urlencoded';
  4         8  
  4         6838  
25              
26             # old names still supported:
27             # bearer_token_scheme => token_scheme
28              
29             sub new(@)
30 2     2 1 1122 { my $class = shift;
31 2 50       9 $class ne __PACKAGE__
32             or carp 'you need to create an extension, not base-class '.__PACKAGE__;
33 2         16 (bless {}, $class)->init( {@_} );
34             }
35              
36             # rfc6849 Appendix B, http://www.w3.org/TR/1999/REC-html401-19991224
37             sub _url_enc($)
38 4     4   14 { my $x = encode 'utf8', shift; # make bytes
39 4         144 $x =~ s/([^A-Za-z0-9 ])/sprintf("%%%02x", ord $1)/ge;
  4         21  
40 4         7 $x =~ s/ /+/g;
41 4         10 $x;
42             }
43              
44             sub init($)
45 2     2 0 6 { my ($self, $args) = @_;
46             my $id = $self->{NOP_id} = $args->{client_id}
47 2 50       12 or carp "profile needs id";
48             my $secret = $self->{NOP_secret} = $args->{client_secret}
49 2 50       7 or carp "profile needs secret";
50              
51 2         7 $self->{NOP_id_enc} = _url_enc $id;
52 2         6 $self->{NOP_secret_enc} = _url_enc $secret;
53              
54 2   33     22 $self->{NOP_agent} = $args->{user_agent} || LWP::UserAgent->new;
55             $self->{NOP_scheme} = $args->{token_scheme}
56 2   50     4839 || $args->{bearer_token_scheme} || 'auth-header:Bearer';
57 2         6 $self->{NOP_scope} = $args->{scope};
58 2         6 $self->{NOP_state} = $args->{state};
59 2         4 $self->{NOP_hd} = $args->{hd};
60 2   50     9 $self->{NOP_method} = $args->{access_token_method} || 'POST';
61 2   50     11 $self->{NOP_acc_param} = $args->{access_token_param} || [];
62 2         5 $self->{NOP_init_params} = $args->{init_params};
63 2         3 $self->{NOP_grant_type} = $args->{grant_type};
64             $self->{NOP_show_secret} = exists $args->{secrets_in_params}
65 2 50       8 ? $args->{secrets_in_params} : 1;
66              
67 2         4 my $site = $self->{NOP_site} = $args->{site};
68 2         6 foreach my $c (qw/access_token protected_resource authorize refresh_token/)
69 8   66     46 { my $link = $args->{$c.'_url'} || $args->{$c.'_path'} || "/oauth/$c";
70 8         38 $self->{"NOP_${c}_url"} = $self->site_url($link);
71 8   100     44 $self->{"NOP_${c}_method"} = $args->{$c.'_method'} || 'POST';
72 8   50     38 $self->{"NOP_${c}_param"} = $args->{$c.'_param'} || [];
73             }
74              
75 2         9 $self;
76             }
77              
78             #----------------
79              
80 3     3 1 520 sub id() {shift->{NOP_id}}
81 0     0 0 0 sub id_enc() {shift->{NOP_id_enc}}
82 2     2 1 8 sub secret() {shift->{NOP_secret}}
83 0     0 0 0 sub secret_enc() {shift->{NOP_secret_enc}}
84 1     1 1 504 sub user_agent() {shift->{NOP_agent}}
85 11     11 1 22 sub site() {shift->{NOP_site}}
86 0     0 1 0 sub scope() {shift->{NOP_scope}}
87 1     1 1 4 sub state() {shift->{NOP_state}}
88 1     1 1 4 sub hd() {shift->{NOP_hd}}
89 1     1 1 4 sub grant_type() {shift->{NOP_grant_type}}
90              
91 0     0 1 0 sub bearer_token_scheme() {shift->{NOP_scheme}}
92              
93             #----------------
94              
95             sub request($@)
96 0     0 1 0 { my ($self, $request) = (shift, shift);
97             #print $request->as_string;
98 0         0 my $response = $self->user_agent->request($request, @_);
99             #print $response->as_string;
100             #$response;
101             }
102              
103              
104             sub request_auth(@)
105 0     0 1 0 { my ($self, $token) = (shift, shift);
106 0         0 my $request;
107 0 0       0 if(@_==1) { $request = shift }
  0         0  
108             else
109 0         0 { my ($method, $uri, $header, $content) = @_;
110 0         0 $request = HTTP::Request->new
111             ( $method => $self->site_url($uri)
112             , $header, $content
113             );
114             }
115 0         0 $self->add_token($request, $token, $self->bearer_token_scheme);
116 0         0 $self->request($request);
117             }
118              
119             #--------------------
120              
121             sub site_url($@)
122 10     10 1 21 { my ($self, $path) = (shift, shift);
123 10 100 66     34 my @params = @_==1 && ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
  1         4  
124 10         23 my $site = $self->site;
125 10 100       35 my $uri = $site ? URI->new_abs($path, $site) : URI->new($path);
126 10 100       11398 $uri->query_form($uri->query_form, @params) if @params;
127 10         211 $uri;
128             }
129              
130              
131             sub add_token($$$)
132 0     0 1 0 { my ($self, $request, $token, $bearer) = @_;
133 0         0 my $access = $token->access_token;
134              
135 0         0 my ($scheme, $opt) = split ':', $bearer;
136 0         0 $scheme = lc $scheme;
137 0 0       0 if($scheme eq 'auth-header')
    0          
    0          
138             { # Specs suggest using Bearer or OAuth2 for this value, but OAuth
139             # appears to be the de facto accepted value.
140             # Going to use OAuth until there is wide acceptance of something else.
141 0   0     0 my $auth_scheme = $opt || 'OAuth';
142 0         0 $request->headers->header(Authorization => "$auth_scheme $access");
143             }
144             elsif($scheme eq 'uri-query')
145 0   0     0 { my $query_param = $opt || 'oauth_token';
146 0         0 $request->uri->query_form($request->uri->query_form
147             , $query_param => $access);
148             }
149             elsif($scheme eq 'form-body')
150 0 0       0 { $request->headers->content_type eq MIME_URLENC
151             or die "embedding access token in request body is only valid "
152             . "for 'MIME_URLENC' content type";
153              
154 0   0     0 my $query_param = $opt || 'oauth_token';
155 0         0 my $content = $request->content;
156 0 0 0     0 $request->add_content(($content && length $content ? '&' : '')
157             . uri_escape($query_param).'='.uri_escape($access));
158             }
159             else
160 0         0 { carp "unknown bearer schema $bearer";
161             }
162              
163 0         0 $request;
164             }
165              
166              
167             sub build_request($$$)
168 3     3 1 7 { my ($self, $method, $uri_base, $params) = @_;
169 3 100       15 my %params = ref $params eq 'HASH' ? %$params : @$params;
170              
171             # rfc6749 section "2.3.1. Client Password"
172             # The Auth Header is always supported, but client_id/client_secret as
173             # parameters may be as well. We do both when ->new(secrets_in_params)
174             # to support old servers.
175             delete @params{qw/client_id client_secret/}
176 3 50       9 unless $self->{NOP_show_secret};
177              
178 3         5 my $request;
179              
180 3 100       9 if($method eq 'POST')
    50          
181 1         4 { my $p = URI->new('http:'); # taken from HTTP::Request::Common
182 1         50 $p->query_form(%params);
183              
184 1         67 $request = HTTP::Request->new
185             ( $method => $uri_base
186             , [Content_Type => MIME_URLENC]
187             , $p->query
188             );
189             }
190             elsif($method eq 'GET')
191 2 50 33     15 { my $uri = blessed $uri_base && $uri_base->isa('URI')
192             ? $uri_base->clone : URI->new($uri_base);
193              
194 2         2661 $uri->query_form($uri->query_form, %params);
195 2         239 $request = HTTP::Request->new($method, $uri);
196             }
197             else
198 0         0 { confess "unknown request method $method";
199             }
200              
201 3         291 my $uri = $request->uri;
202 3         23 my $head = $request->headers;
203 3         20 $request->protocol('HTTP/1.1');
204              
205             # 2016-01-15 Instagram does not like the portnumber to appear
206             # my ($host, $port) = ($uri->host, $uri->port);
207             # $host .= ':'.$port if $port != $uri->default_port;
208 3         31 $head->header(Host => $uri->host);
209              
210 3         230 $head->header(Connection => 'Keep-Alive');
211 3         98 $request;
212             }
213              
214              
215             sub params_from_response($$)
216 2     2 1 2008 { my ($self, $response, $why) = @_;
217 2         4 my ($error, $content);
218 2 50 33     14 $content = $response->decoded_content || $response->content if $response;
219              
220 2 50       269 if(!$response)
    50          
221 0         0 { $error = 'no response received';
222             }
223             elsif(!$response->is_success)
224 0         0 { $error = 'received error: '.$response->status_line;
225             }
226             else
227             { # application/json is often not correctly configured: is not
228             # (yet) an apache pre-configured extension :(
229 2 100       15 if(my $params = eval {decode_json $content} )
  2         26  
230             { # content is JSON
231 1 50       8 return ref $params eq 'HASH' ? %$params : @$params;
232             }
233              
234             # otherwise form-encoded parameters (I hope)
235 1         5 my $uri = URI->new;
236 1         53 $uri->query($content);
237 1         56 my @res_params = $uri->query_form;
238 1 50       88 return @res_params if @res_params;
239              
240 0         0 $error = "cannot read parameters from response";
241             }
242            
243 0 0       0 substr($content, 200) = '...' if length $content > 200;
244 0         0 die "failed oauth call $why: $error\n$content\n";
245             }
246              
247             sub authorize_method() {panic} # user must use autorize url
248 0     0 0 0 sub access_token_method() {shift->{NOP_access_token_method} }
249 1     1 0 1464 sub refresh_token_method() {shift->{NOP_refresh_token_method} }
250 0     0 0 0 sub protected_resource_method() {shift->{NOP_protected_resource_method} }
251              
252 1     1 0 3 sub authorize_url() {shift->{NOP_authorize_url}}
253 1     1 0 1116 sub access_token_url() {shift->{NOP_access_token_url}}
254 1     1 0 6 sub refresh_token_url() {shift->{NOP_refresh_token_url}}
255 0     0 0 0 sub protected_resource_url() {shift->{NOP_protected_resource_url}}
256              
257             sub authorize_params(%)
258 1     1 0 3 { my $self = shift;
259 1         1 my %params = (@{$self->{NOP_authorize_param}}, @_);
  1         4  
260 1   33     3 $params{scope} ||= $self->scope;
261 1   33     18 $params{state} ||= $self->state;
262 1   33     12 $params{hd} ||= $self->hd;
263 1   33     5 $params{client_id} ||= $self->id;
264 1         3 \%params;
265             }
266              
267             sub access_token_params(%)
268 1     1 0 2 { my $self = shift;
269 1         1 my %params = (@{$self->{NOP_access_token_param}}, @_);
  1         6  
270 1   50     7 $params{code} ||= '';
271 1   33     4 $params{client_id} ||= $self->id;
272 1   33     6 $params{client_secret} ||= $self->secret;
273 1   33     7 $params{grant_type} ||= $self->grant_type;
274 1         3 \%params;
275             }
276              
277             sub refresh_token_params(%)
278 0     0 0   { my $self = shift;
279 0           my %params = (@{$self->{NOP_refresh_token_param}}, @_);
  0            
280 0   0       $params{client_id} ||= $self->id;
281 0   0       $params{client_secret} ||= $self->secret;
282 0           \%params;
283             }
284              
285             sub protected_resource_params(%)
286 0     0 0   { my $self = shift;
287 0           my %params = (@{$self->{NOP_protected_resource_param}}, @_);
  0            
288 0           \%params;
289             }
290              
291             1;