File Coverage

blib/lib/OAuth/Lite2/ParamMethod/AuthHeader.pm
Criterion Covered Total %
statement 93 94 98.9
branch 22 24 91.6
condition 11 16 68.7
subroutine 16 16 100.0
pod 4 5 80.0
total 146 155 94.1


line stmt bran cond sub pod time code
1             package OAuth::Lite2::ParamMethod::AuthHeader;
2 10     10   45 use strict;
  10         15  
  10         301  
3 10     10   48 use warnings;
  10         14  
  10         190  
4 10     10   2310 use bytes ();
  10         32  
  10         191  
5 10     10   823 use parent 'OAuth::Lite2::ParamMethod';
  10         323  
  10         51  
6              
7 10     10   323743 use URI;
  10         13412  
  10         254  
8 10     10   9560 use MIME::Base64 qw(decode_base64);
  10         8219  
  10         712  
9 10     10   1575 use Hash::MultiValue;
  10         2589  
  10         531  
10 10     10   9986 use HTTP::Request;
  10         56015  
  10         383  
11 10     10   72 use HTTP::Headers;
  10         19  
  10         203  
12 10     10   1645 use Params::Validate;
  10         20210  
  10         621  
13 10     10   5300 use OAuth::Lite2::Util qw(encode_param decode_param build_content);
  10         25  
  10         12074  
14              
15             =head1 NAME
16              
17             OAuth::Lite2::ParamMethod::AuthHeader - builder/parser for OAuth 2.0 AuthHeader type of parameter
18              
19             =head1 SYNOPSIS
20              
21             my $meth = OAuth::Lite2::ParamMethod::AuthHeader->new;
22              
23             # server side
24             if ($meth->match( $plack_request )) {
25             my ($token, $params) = $meth->parse( $plack_request );
26             }
27              
28             # client side
29             my $http_req = $meth->request_builder(...);
30              
31             =head1 DESCRIPTION
32              
33             builder/parser for OAuth 2.0 AuthHeader type of parameter
34              
35             =head1 METHODS
36              
37             =head2 new
38              
39             Constructor
40              
41             =head2 match( $plack_request )
42              
43             Returns true if passed L object is matched for the type of this method.
44              
45             if ( $meth->match( $plack_request ) ) {
46             ...
47             }
48              
49             =cut
50              
51             sub match {
52 46     46 1 75 my ($self, $req) = @_;
53 46         162 my $header = $req->header("Authorization");
54 46   66     6601 return ($header && $header =~ /^\s*(OAuth|Bearer)(.*)$/);
55             }
56              
57             =head2 parse( $plack_request )
58              
59             Parse the L, and returns access token and oauth parameters.
60              
61             my ($token, $params) = $meth->parse( $plack_request );
62              
63             =cut
64              
65             sub parse {
66 21     21 1 950 my ($self, $req) = @_;
67 21         58 my $header = $req->header("Authorization");
68 21         683 my $token;
69 21 100       148 if ($header =~ s/^\s*(OAuth|Bearer)\s+([^\s\,]*)//){
70 19         49 $token = $2;
71             }
72 21         143 my $params = Hash::MultiValue->new;
73 21         693 $header =~ s/^\s*(OAuth|Bearer)\s*([^\s\,]*)//;
74              
75 21 100       61 if ($header) {
76 1         4 $header =~ s/^\s*\,\s*//;
77 1         11 for my $attr (split /,\s*/, $header) {
78 4         115 my ($key, $val) = split /=/, $attr, 2;
79 4         14 $val =~ s/^"//;
80 4         15 $val =~ s/"$//;
81 4         13 $params->add($key, decode_param($val));
82             }
83             }
84 21         138 return ($token, $params);
85             }
86              
87             =head2 build_request( %params )
88              
89             Build L object.
90              
91             my $req = $meth->build_request(
92             url => $url,
93             method => $http_method,
94             token => $access_token,
95             oauth_params => $oauth_params,
96             params => $params,
97             content => $content,
98             headers => $headers,
99             );
100              
101             =cut
102              
103             sub build_request {
104 10     10 1 10456 my $self = shift;
105 10         422 my %args = Params::Validate::validate(@_, {
106             url => 1,
107             method => 1,
108             token => 1,
109             oauth_params => 1,
110             params => { optional => 1 },
111             content => { optional => 1 },
112             headers => { optional => 1 },
113             });
114 10   50     105 my $oauth_params = $args{oauth_params} || {};
115 10         39 my @pairs = sort map { sprintf q{%s="%s"},
  4         111  
116             encode_param($_),
117             encode_param($oauth_params->{$_})
118             } keys %$oauth_params;
119              
120 10   100     81 my $params = $args{params} || {};
121 10         22 my $method = uc $args{method};
122 10         18 my $headers = $args{headers};
123 10 100       27 if (defined $headers) {
124 2 50       8 if (ref($headers) eq 'ARRAY') {
125 2         12 $headers = HTTP::Headers->new(@$headers);
126             } else {
127 0         0 $headers = $headers->clone;
128             }
129             } else {
130 8         49 $headers = HTTP::Headers->new;
131             }
132 10         170 my $auth_header = sprintf(q{Bearer %s}, $args{token});
133 10 100       39 $auth_header .= ", " . join(", ", @pairs) if @pairs > 0;
134 10         37 $headers->header(Authorization => $auth_header);
135              
136 10 100 66     401 if ($method eq 'GET' || $method eq 'DELETE') {
137 6         30 my $url = URI->new($args{url});
138 6         15860 $url->query_form(%$params);
139 6         471 my $req = HTTP::Request->new($method, $url->as_string, $headers);
140 6         1228 return $req;
141             } else {
142 4 100       15 unless ($headers->header("Content-Type")) {
143 2         52 $headers->header("Content-Type",
144             "application/x-www-form-urlencoded");
145             }
146 4         119 my $content_type = $headers->header("Content-Type");
147 4 100 66     114 my $content = ($content_type eq "application/x-www-form-urlencoded")
148             ? build_content($params)
149             : $args{content} || build_content($params);
150 4         22 $headers->header("Content-Length", bytes::length($content));
151 4         1383 my $req = HTTP::Request->new($method, $args{url}, $headers, $content);
152 4         732 return $req;
153             }
154             }
155              
156             =head2 is_legacy( $plack_request )
157              
158             Returns true if passed L object is based draft version 10.
159              
160             if ( $meth->is_legacy( $plack_request ) ) {
161             ...
162             }
163              
164             =cut
165              
166             sub is_legacy {
167 18     18 1 1322 my ($self, $req) = @_;
168 18         62 my $header = $req->header("Authorization");
169 18   66     671 return ($header && $header =~ /^\s*OAuth(.*)$/);
170             }
171              
172             =head2 basic_clientcredentials( $plack_request )
173              
174             Returns Hash reference if passed L object has client credentials in Authorization header.
175              
176             my $basic_clientcredentials = $meth->basic_credentials( $plack_request );
177             if( defined($basic_clientcredentials) ){
178             my $client_id = $basic_clientcredentials->{client_id};
179             my $client_secret = $basic_clientcredentials->{client_secret};
180             }
181              
182             =cut
183              
184             sub basic_credentials{
185 48     48 0 6556 my ($self, $req) = @_;
186              
187 48         148 my %credentials = (
188             client_id => '',
189             client_secret => ''
190             );
191 48         156 my $header = $req->header("Authorization");
192 48 100       3149 return \%credentials unless (defined($header));
193              
194 8         10 my $decoded;
195 8 100       39 if ( $header =~ /\A\s*(Basic)\s([^\s\,]*)/ ){
196 4         34 $decoded = decode_base64($2);
197 4 100       19 return \%credentials unless (index($decoded,':') > 0);
198              
199 2         10 my @split_credentials = split(/:/, $decoded);
200 2 50       7 return \%credentials unless (scalar(@split_credentials) == 2);
201              
202 2         11 %credentials = (
203             client_id => $split_credentials[0],
204             client_secret => $split_credentials[1]
205             );
206             }
207 6         19 return \%credentials;
208             };
209              
210             =head1 SEE ALSO
211              
212             L
213             L
214             L
215             L
216              
217             =head1 AUTHOR
218              
219             Lyo Kato, Elyo.kato@gmail.comE
220              
221             =head1 COPYRIGHT AND LICENSE
222              
223             Copyright (C) 2010 by Lyo Kato
224              
225             This library is free software; you can redistribute it and/or modify
226             it under the same terms as Perl itself, either Perl version 5.8.8 or,
227             at your option, any later version of Perl 5 you may have available.
228              
229             =cut
230              
231             1;