File Coverage

blib/lib/OAuth/Lite/Util.pm
Criterion Covered Total %
statement 81 88 92.0
branch 12 22 54.5
condition 6 13 46.1
subroutine 18 18 100.0
pod 8 8 100.0
total 125 149 83.8


line stmt bran cond sub pod time code
1             package OAuth::Lite::Util;
2              
3 11     11   567 use strict;
  11         19  
  11         339  
4 11     11   60 use warnings;
  11         21  
  11         341  
5              
6 11     11   2411 use OAuth::Lite;
  11         25  
  11         239  
7 11     11   5021 use URI;
  11         58283  
  11         318  
8 11     11   133 use URI::Escape;
  11         26  
  11         834  
9 11     11   6221 use Crypt::OpenSSL::Random;
  11         14001  
  11         597  
10 11     11   102 use Carp ();
  11         27  
  11         221  
11              
12 11     11   52 use base 'Exporter';
  11         23  
  11         15418  
13              
14             our %EXPORT_TAGS = ( all => [qw/
15             gen_random_key
16             encode_param
17             decode_param
18             create_signature_base_string
19             parse_auth_header
20             build_auth_header
21             normalize_params
22             /]);
23              
24             our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
25              
26             =head1 NAME
27              
28             OAuth::Lite::Util - utility for OAuth
29              
30             =head1 SYNPSIS
31              
32             use OAuth::Lite::Util qw(
33             gen_random_key
34             encode_param
35             decode_param
36             create_signature_base_string
37             parse_auth_header
38             );
39              
40             my $random = gen_random_key(8);
41             my $enocded = encode_param($param);
42             my $deocded = decode_param($encoded);
43              
44             my $base_string = create_signature_base_string('GET',
45             'http://example.com/path?query', $params);
46              
47             my $header = q{OAuth realm="http://example.com/api/resource", oauth_consumer_key="hogehoge", ... };
48             my ($realm, $oauth_params) = parse_auth_header($header);
49             say $realm;
50             say $oauth_params->{oauth_consumer_key};
51             say $oauth_params->{oauth_version};
52             ...
53              
54             =head1 DESCRIPTION
55              
56             Utilty functions for OAuth are implemented here.
57              
58             =head1 PAY ATTENTION
59              
60             If you use OAuth 1.31 or older version, its has invalid way to normalize params.
61             (when there are two or more same key and they contain ASCII and non ASCII value)
62              
63             But the many services have already supported deprecated version,
64             and the correct way breaks backward compatibility.
65             So, from 1.32, supported both correct and deprecated method.
66              
67             use $OAuth::Lite::USE_DEPRECATED_NORMALIZER to switch behaviour.
68             Currently 1 is set by default to keep backward compatibility.
69              
70             use OAuth::Lite::Util;
71             use OAuth::Lite;
72             $OAuth::Lite::USE_DEPRECATED_NORMALIZER = 0;
73             ...
74              
75              
76              
77             =head1 METHODS
78              
79             =head2 gen_random_key($length)
80              
81             Generate random octet string.
82             You can indicate the byte-length of generated string. (10 is set by default)
83             If 10 is passed, returns 20-length octet string.
84              
85             use OAuth::Lite::Util qw(gen_random_key);
86             my $key1 = gen_random_key();
87             my $key2 = gen_random_key();
88              
89             =cut
90              
91             sub gen_random_key {
92 15   100 15 1 1279 my $length = shift || 10;
93 15         1017 return unpack("H*", Crypt::OpenSSL::Random::random_bytes($length));
94             }
95              
96             =head2 encode_param($param)
97              
98             Encode parameter according to the way defined in OAuth Core spec.
99              
100             =cut
101              
102             sub encode_param {
103 543     543 1 11587 my $param = shift;
104 543         980 URI::Escape::uri_escape($param, '^\w.~-');
105             }
106              
107             =head2 decode_param($encoded_param)
108              
109             Decode the encoded parameter.
110              
111             =cut
112              
113             sub decode_param {
114 36     36 1 552 my $param = shift;
115 36         84 URI::Escape::uri_unescape($param);
116             }
117              
118             =head2 create_signature_base_string($http_method, $request_uri, $params);
119              
120             my $method = "GET";
121             my $uri = "http://example.com/api/for/some-resource";
122             my $parmas = {
123             oauth_consumer_key => 'foo-bar',
124             oauth_signature_method => 'HMAC-SHA1',
125             oauth_version => '1.0',
126             ...
127             };
128             my $base_string = create_signature_base_string($method, $uri, $params);
129              
130             =cut
131              
132             sub create_signature_base_string {
133 18     18 1 2200 my ($method, $url, $params) = @_;
134 18         48 $method = uc $method;
135 18         85 $params = {%$params};
136 18         40 delete $params->{oauth_signature};
137 18         34 delete $params->{realm};
138 18         38 my $normalized_request_url = normalize_request_url($url);
139 18         49 my $normalized_params = normalize_params($params);
140 18         59 my $signature_base_string = join('&', map(encode_param($_),
141             $method, $normalized_request_url, $normalized_params));
142 18         1291 $signature_base_string;
143             }
144              
145             =head2 normalize_request_url($url);
146              
147             Normalize url according to the way the OAuth Core spec defines.
148              
149             my $string = normalize_request_url('http://Example.com:80/path?query');
150             # http://example.com/path
151             my $string = normalize_request_url('https://Example.com:443/path?query');
152             # https://example.com/path
153             my $string = normalize_request_url('http://Example.com:8080/path?query');
154             # http://example.com:8080/path
155              
156             =cut
157              
158             sub normalize_request_url {
159 20     20 1 532 my $uri = shift;
160 20 50 33     125 $uri = URI->new($uri) unless (ref $uri && ref $uri eq 'URI');
161 20 50 33     33184 unless (lc $uri->scheme eq 'http' || lc $uri->scheme eq 'https') {
162 0         0 Carp::croak qq/Invalid request url, "$uri"/;
163             }
164 20         743 my $port = $uri->port;
165 20 50 33     904 my $request_url = ($port && ($port == 80 || $port == 443))
166             ? sprintf(q{%s://%s%s}, lc($uri->scheme), lc($uri->host), $uri->path)
167             : sprintf(q{%s://%s:%d%s}, lc($uri->scheme), lc($uri->host), $port, $uri->path);
168 20         1159 $request_url;
169             }
170              
171             =head2 normalize_params($params);
172              
173             Sort and encode params and concatenates them
174             according to the way OAuth Core spec defines.
175              
176             my $string = normalize_params({
177             a => 1, c => 'hi%20there', f => [25, 50, 'a'], z => [ 'p', 't' ]
178             });
179              
180             =cut
181              
182             sub normalize_params {
183 27 100   27 1 642 $OAuth::Lite::USE_DEPRECATED_NORMALIZER
184             ? _normalize_params_deprecated(@_)
185             : _normalize_params(@_);
186             }
187              
188             sub _normalize_params {
189 1     1   3 my $params = shift;
190 1         2 my %encoded_params = ();
191 1         5 for my $k (keys %$params) {
192 10 50       243 if (!ref $params->{$k}) {
    0          
193 10         21 $encoded_params{encode_param($k)} = encode_param($params->{$k});
194             } elsif (ref $params->{$k} eq 'ARRAY') {
195 0         0 $encoded_params{encode_param($k)} = [ map { encode_param($_) } @{$params->{$k}} ];
  0         0  
  0         0  
196             }
197             }
198 1         27 my @pairs = ();
199 1         9 for my $k (sort keys %encoded_params) {
200 10 50       20 if (!ref $encoded_params{$k}) {
    0          
201 10         26 push @pairs, sprintf(q{%s=%s}, $k, $encoded_params{$k});
202             }
203             elsif (ref $encoded_params{$k} eq 'ARRAY') {
204 0         0 for my $v (sort @{ $encoded_params{$k} }) {
  0         0  
205 0         0 push @pairs, sprintf(q{%s=%s}, $k, $v);
206             }
207             }
208             }
209 1         9 return join('&', @pairs);
210             }
211              
212             sub _normalize_params_deprecated {
213 26     26   44 my $params = shift;
214 26         52 my @pairs = ();
215 26         180 for my $k (sort keys %$params) {
216 179 100       4634 if (!ref $params->{$k}) {
    100          
217             push @pairs,
218 167         296 sprintf(q{%s=%s}, encode_param($k), encode_param($params->{$k}));
219             }
220             elsif (ref $params->{$k} eq 'ARRAY') {
221 11         20 for my $v (sort @{ $params->{$k} }) {
  11         37  
222 22         324 push @pairs,
223             sprintf(q{%s=%s}, encode_param($k), encode_param($v));
224             }
225             }
226             }
227 26         862 return join('&', @pairs);
228             }
229              
230             =head2 parse_auth_header($header)
231              
232             Parse authorization/www-authentication header for OAuth.
233             And return the realm and other params.
234              
235             # service provider side
236             my $header = $r->headers_in->{Authorization};
237             my ($realm, $params) = parse_auth_header($header);
238             say $params->{oauth_token};
239             say $params->{oauth_consumer_key};
240             say $params->{oauth_signature_method};
241             ...
242              
243             # consumer side
244             my $header = $res->header('WWW-Authenticate');
245             my ($realm) = parse_auth_header($header);
246              
247             =cut
248              
249             sub parse_auth_header {
250 1     1 1 34 my $header = shift;
251 1         7 $header =~ s/^\s*OAuth\s*//;
252 1         4 my $params = {};
253 1         9 for my $attr (split /,\s*/, $header) {
254 7         55 my ($key, $val) = split /=/, $attr, 2;
255 7         20 $val =~ s/^"//;
256 7         18 $val =~ s/"$//;
257 7         29 $params->{$key} = decode_param($val);
258             }
259 1         9 my $realm = delete $params->{realm};
260 1 50       6 return wantarray ? ($realm, $params) : $realm;
261             }
262              
263             =head2 build_auth_header(%params)
264              
265             my $header = build_auth_header($realm, {
266             oauth_consumer_key => '...',
267             oauth_signature_method => '...',
268             ... and other oauth params
269             });
270              
271             =cut
272              
273             sub build_auth_header {
274 2     2 1 7 my ($realm, $params) = @_;
275 2   50     14 my $head = sprintf q{OAuth realm="%s"}, $realm || '';
276             my $authorization_header = join(', ', $head,
277 22         96 sort { $a cmp $b } map(sprintf(q{%s="%s"}, encode_param($_), encode_param($params->{$_})),
278 2         14 grep { /^x?oauth_/ } keys %$params));
  17         61  
279 2         9 $authorization_header;
280             }
281              
282             =head1 AUTHOR
283              
284             Lyo Kato, C
285              
286             =head1 COPYRIGHT AND LICENSE
287              
288             This library is free software; you can redistribute it and/or modify
289             it under the same terms as Perl itself, either Perl version 5.8.6 or,
290             at your option, any later version of Perl 5 you may have available.
291              
292             =cut
293              
294             1;