File Coverage

blib/lib/Net/Amazon/S3/Signature/V4Implementation.pm
Criterion Covered Total %
statement 147 151 97.3
branch 25 38 65.7
condition 13 19 68.4
subroutine 27 27 100.0
pod 2 3 66.6
total 214 238 89.9


line stmt bran cond sub pod time code
1             package Net::Amazon::S3::Signature::V4Implementation;
2             # ABSTRACT: Implements the Amazon Web Services signature version 4, AWS4-HMAC-SHA256 (copy of Net::Amazon::Signature::V4)
3             $Net::Amazon::S3::Signature::V4Implementation::VERSION = '0.98';
4              
5 96     96   813 use strict;
  96         274  
  96         3470  
6 96     96   612 use warnings;
  96         242  
  96         3093  
7 96     96   54866 use sort 'stable';
  96         61866  
  96         674  
8              
9 96     96   5371 use Digest::SHA qw/sha256_hex hmac_sha256 hmac_sha256_hex/;
  96         275  
  96         7035  
10 96     96   55668 use Time::Piece ();
  96         723824  
  96         3100  
11 96     96   1015 use URI::Escape;
  96         374  
  96         6698  
12 96     96   732 use URI;
  96         252  
  96         2165  
13 96     96   547 use URI::QueryParam;
  96         248  
  96         242625  
14              
15             our $ALGORITHM = 'AWS4-HMAC-SHA256';
16             our $MAX_EXPIRES = 604800; # Max, 7 days
17              
18             our $X_AMZ_ALGORITHM = 'X-Amz-Algorithm';
19             our $X_AMZ_CONTENT_SHA256 = 'X-Amz-Content-Sha256';
20             our $X_AMZ_CREDENTIAL = 'X-Amz-Credential';
21             our $X_AMZ_DATE = 'X-Amz-Date';
22             our $X_AMZ_EXPIRES = 'X-Amz-Expires';
23             our $X_AMZ_SIGNEDHEADERS = 'X-Amz-SignedHeaders';
24             our $X_AMZ_SIGNATURE = 'X-Amz-Signature';
25              
26              
27              
28             sub new {
29 7     7 0 32 my $class = shift;
30 7         25 my ( $access_key_id, $secret, $endpoint, $service ) = @_;
31 7         44 my $self = {
32             access_key_id => $access_key_id,
33             secret => $secret,
34             endpoint => $endpoint,
35             service => $service,
36             };
37 7         17 bless $self, $class;
38 7         27 return $self;
39             }
40              
41              
42             sub sign {
43 1     1 1 4 my ( $self, $request ) = @_;
44              
45 1         212 $request = $self->_augment_request( $request );
46              
47 1         5 my $authz = $self->_authorization( $request );
48 1         6 $request->header( Authorization => $authz );
49 1         75 return $request;
50             }
51              
52              
53             sub sign_uri {
54 6     6 1 160 my ( $self, $uri, $expires_in, $for_method ) = @_;
55              
56 6         21 my $request = $self->_augment_uri( $uri, $expires_in, $for_method );
57              
58 6         24 my $signature = $self->_signature( $request );
59              
60 6         24 $uri = $request->uri;
61 6         55 my $query = $uri->query;
62 6         91 $uri->query( undef );
63 6         116 $uri = $uri . '?' . $self->_sort_query_string( $query );
64 6         27 $uri .= "&$X_AMZ_SIGNATURE=$signature";
65              
66 6         94 return $uri;
67             }
68              
69             # _headers_to_sign:
70             # Return the sorted lower case headers as required by the generation of canonical headers
71              
72             sub _headers_to_sign {
73 15     15   29 my $req = shift;
74              
75 15 100       182 my @headers_to_sign = $req->uri->query_param( $X_AMZ_SIGNEDHEADERS )
76             ? $req->uri->query_param( $X_AMZ_SIGNEDHEADERS )
77             : $req->headers->header_field_names
78             ;
79              
80 15         3962 return sort { $a cmp $b } map { lc } @headers_to_sign
  33         56  
  33         91  
81             }
82              
83             # _augment_request:
84             # Append mandatory header fields
85              
86             sub _augment_request {
87 1     1   5 my ( $self, $request ) = @_;
88              
89 1 50       6 $request->header($X_AMZ_DATE => $self->_format_amz_date( $self->_req_timepiece($request) ))
90             unless $request->header($X_AMZ_DATE);
91              
92 1 50       113 $request->header($X_AMZ_CONTENT_SHA256 => sha256_hex($request->content))
93             unless $request->header($X_AMZ_CONTENT_SHA256);
94              
95 1         186 return $request;
96             }
97              
98             # _augment_uri:
99             # Append mandatory uri parameters
100              
101             sub _augment_uri {
102 6     6   17 my ($self, $uri, $expires_in, $method) = @_;
103              
104 6   50     28 my $request = HTTP::Request->new( $method || GET => $uri );
105              
106 6 50       461 $request->uri->query_param( $X_AMZ_DATE => $self->_format_amz_date( $self->_now ) )
107             unless $request->uri->query_param( $X_AMZ_DATE );
108              
109 6 50       1180 $request->uri->query_param( $X_AMZ_ALGORITHM => $ALGORITHM )
110             unless $request->uri->query_param( $X_AMZ_ALGORITHM );
111              
112 6 50       1305 $request->uri->query_param( $X_AMZ_CREDENTIAL => $self->_credential( $request ) )
113             unless $request->uri->query_param( $X_AMZ_CREDENTIAL );
114              
115 6 50 33     1425 $request->uri->query_param( $X_AMZ_EXPIRES => $expires_in || $MAX_EXPIRES )
116             unless $request->uri->query_param( $X_AMZ_EXPIRES );
117 6 50       2355 $request->uri->query_param( $X_AMZ_EXPIRES => $MAX_EXPIRES )
118             if $request->uri->query_param( $X_AMZ_EXPIRES ) > $MAX_EXPIRES;
119              
120 6         781 $request->uri->query_param( $X_AMZ_SIGNEDHEADERS => 'host' );
121              
122 6         1802 return $request;
123             }
124              
125             # _canonical_request:
126             # Construct the canonical request string from an HTTP::Request.
127              
128             sub _canonical_request {
129 7     7   29 my ( $self, $req ) = @_;
130              
131 7         25 my $creq_method = $req->method;
132              
133 7 100       114 my ( $creq_canonical_uri, $creq_canonical_query_string ) =
134             ( $req->uri =~ m@([^?]*)\?(.*)$@ )
135             ? ( $1, $2 )
136             : ( $req->uri, '' );
137 7         182 $creq_canonical_uri =~ s@^https?://[^/]*/?@/@;
138 7         41 $creq_canonical_uri = _simplify_uri( $creq_canonical_uri );
139 7         24 $creq_canonical_query_string = $self->_sort_query_string( $creq_canonical_query_string );
140              
141             # Ensure Host header is present as its required
142 7 50       60 if (!$req->header('host')) {
143 7 100       375 my $host = $req->uri->_port
144             ? $req->uri->host_port
145             : $req->uri->host
146             ;
147 7         491 $req->header('Host' => $host);
148             }
149 7   100     392 my $creq_payload_hash = $req->header($X_AMZ_CONTENT_SHA256)
150             # Signed uri doesn't have content
151             || 'UNSIGNED-PAYLOAD';
152              
153             # There's a bug in AMS4 which causes requests without x-amz-date set to be rejected
154             # so we always add one if its not present.
155 7         386 my $amz_date = $req->header($X_AMZ_DATE);
156 7         312 my @sorted_headers = _headers_to_sign( $req );
157             my $creq_canonical_headers = join '',
158             map {
159 7         20 sprintf "%s:%s\x0a",
160             lc,
161 13         46 join ',', sort {$a cmp $b } _trim_whitespace($req->header($_) )
  0         0  
162             }
163             @sorted_headers;
164 7         26 my $creq_signed_headers = $self->_signed_headers( $req );
165 7         27 my $creq = join "\x0a",
166             $creq_method, $creq_canonical_uri, $creq_canonical_query_string,
167             $creq_canonical_headers, $creq_signed_headers, $creq_payload_hash;
168              
169 7         27 return $creq;
170             }
171              
172             # _string_to_sign
173             # Construct the string to sign.
174              
175             sub _string_to_sign {
176 7     7   25 my ( $self, $req ) = @_;
177 7         22 my $dt = $self->_req_timepiece( $req );
178 7         408 my $creq = $self->_canonical_request($req);
179 7         23 my $sts_request_date = $self->_format_amz_date( $dt );
180 7         287 my $sts_credential_scope = join '/', $dt->strftime('%Y%m%d'), $self->{endpoint}, $self->{service}, 'aws4_request';
181 7         326 my $sts_creq_hash = sha256_hex( $creq );
182              
183 7         30 my $sts = join "\x0a", $ALGORITHM, $sts_request_date, $sts_credential_scope, $sts_creq_hash;
184 7         37 return $sts;
185             }
186              
187             # _authorization
188             # Construct the authorization string
189              
190             sub _signature {
191 7     7   18 my ( $self, $req ) = @_;
192              
193 7         22 my $dt = $self->_req_timepiece( $req );
194 7         546 my $sts = $self->_string_to_sign( $req );
195 7         25 my $k_date = hmac_sha256( $dt->strftime('%Y%m%d'), 'AWS4' . $self->{secret} );
196 7         322 my $k_region = hmac_sha256( $self->{endpoint}, $k_date );
197 7         58 my $k_service = hmac_sha256( $self->{service}, $k_region );
198 7         90 my $k_signing = hmac_sha256( 'aws4_request', $k_service );
199              
200 7         71 my $authz_signature = hmac_sha256_hex( $sts, $k_signing );
201 7         25 return $authz_signature;
202             }
203              
204             sub _credential {
205 7     7   589 my ( $self, $req ) = @_;
206              
207 7         22 my $dt = $self->_req_timepiece( $req );
208              
209 7         539 my $authz_credential = join '/', $self->{access_key_id}, $dt->strftime('%Y%m%d'), $self->{endpoint}, $self->{service}, 'aws4_request';
210 7         300 return $authz_credential;
211             }
212              
213             sub _signed_headers {
214 8     8   56 my ( $self, $req ) = @_;
215              
216 8         23 my $authz_signed_headers = join ';', _headers_to_sign( $req );
217 8         28 return $authz_signed_headers;
218             }
219              
220             sub _authorization {
221 1     1   3 my ( $self, $req ) = @_;
222              
223 1         6 my $authz_signature = $self->_signature( $req );
224 1         5 my $authz_credential = $self->_credential( $req );
225 1         4 my $authz_signed_headers = $self->_signed_headers( $req );
226              
227 1         6 my $authz = "$ALGORITHM Credential=$authz_credential,SignedHeaders=$authz_signed_headers,Signature=$authz_signature";
228 1         4 return $authz;
229              
230             }
231              
232             sub _simplify_uri {
233 7     7   25 my $orig_uri = shift;
234 7         44 my @parts = split /\//, $orig_uri;
235 7         18 my @simple_parts = ();
236 7         26 for my $part ( @parts ) {
237 18 100 66     88 if ( ! length $part || $part eq '.' ) {
    50          
238             } elsif ( $part eq '..' ) {
239 0         0 pop @simple_parts;
240             } else {
241 12         30 push @simple_parts, $part;
242             }
243             }
244 7         26 my $simple_uri = '/' . join '/', @simple_parts;
245 7 50 66     39 $simple_uri .= '/' if $orig_uri =~ m@/$@ && $simple_uri !~ m@/$@;
246 7         24 return $simple_uri;
247             }
248             sub _sort_query_string {
249 13     13   57 my $self = shift;
250 13 100       34 return '' unless $_[0];
251 12         20 my @params;
252 12         46 for my $param ( split /&/, $_[0] ) {
253             my ( $key, $value ) =
254 60         162 map { tr/+/ /; uri_escape( uri_unescape( $_ ) ) } # escape all non-unreserved chars
  120         1498  
  120         245  
255             split /=/, $param;
256 60 50       1444 push @params, [$key, (defined $value ? $value : '')];
257             #push @params, [$key, $value];
258             }
259             return join '&',
260 60         228 map { join '=', grep defined, @$_ }
261 12 50       68 sort { ( $a->[0] cmp $b->[0] ) || ( $a->[1] cmp $b->[1] ) }
  108         263  
262             @params;
263             }
264             sub _trim_whitespace {
265 13     13   558 return map { my $str = $_; $str =~ s/^\s*//; $str =~ s/\s*$//; $str } @_;
  13         25  
  13         64  
  13         83  
  13         91  
266             }
267             sub _str_to_timepiece {
268 21     21   42 my $date = shift;
269 21 50       114 if ( $date =~ m/^\d{8}T\d{6}Z$/ ) {
270             # assume basic ISO 8601, as demanded by AWS
271 21         88 return Time::Piece->strptime($date, '%Y%m%dT%H%M%SZ');
272             } else {
273             # assume the format given in the AWS4 test suite
274 0         0 $date =~ s/^.{5}//; # remove weekday, as Amazon's test suite contains internally inconsistent dates
275 0         0 return Time::Piece->strptime($date, '%d %b %Y %H:%M:%S %Z');
276             }
277             }
278              
279             sub _format_amz_date {
280 14     14   505 my ($self, $dt) = @_;
281              
282 14         54 $dt->strftime('%Y%m%dT%H%M%SZ');
283             }
284              
285             sub _now {
286 7     7   354 return scalar Time::Piece->gmtime;
287             }
288              
289             sub _req_timepiece {
290 22     22   118 my ($self, $req) = @_;
291 22   100     89 my $x_date = $req->header($X_AMZ_DATE) || $req->uri->query_param($X_AMZ_DATE);
292 22   66     3587 my $date = $x_date || $req->header('Date');
293 22 100       98 if (!$date) {
294             # No date set by the caller so set one up
295 1         6 my $piece = $self->_now;
296 1         115 $req->date($piece->epoch);
297 1         208 return $piece
298             }
299 21         73 return _str_to_timepiece($date);
300             }
301              
302             1;
303              
304             __END__
305              
306             =pod
307              
308             =encoding UTF-8
309              
310             =head1 NAME
311              
312             Net::Amazon::S3::Signature::V4Implementation - Implements the Amazon Web Services signature version 4, AWS4-HMAC-SHA256 (copy of Net::Amazon::Signature::V4)
313              
314             =head1 VERSION
315              
316             version 0.98
317              
318             =head1 DESCRIPTION
319              
320             This package clones L<Net::Amazon::Signature::V4> 0.19 adding support for
321             signing URIs (GET request)
322              
323             Until https://github.com/Grinnz/Net-Amazon-Signature-V4/pull/5 will be merged
324             we have to maintain our clone.
325              
326             =head1 Net::Amazon::Signature::S4 AUTHORS
327              
328             Tim Nordenfur, C<< <tim at gurka.se> >>
329              
330             Maintained by Dan Book, C<< <dbook at cpan.org> >>
331              
332             =head2 sign( $request )
333              
334             Signs a request with your credentials by appending the Authorization header. $request should be an HTTP::Request. The signed request is returned.
335              
336             =head2 sign_uri( $uri, $expires_in?, $for_method? )
337              
338             Signs an uri with your credentials by appending the Authorization query parameters.
339              
340             C<< $expires_in >> integer value in range 1..604800 (1 second .. 7 days).
341              
342             C<< $expires_in >> default value is its maximum: 604800
343              
344             C<< $for_method >> HTTP method this uri should be signed for, default C<GET>
345              
346             The signed uri is returned.
347              
348             =head1 AUTHOR
349              
350             Branislav Zahradník <barney@cpan.org>
351              
352             =head1 COPYRIGHT AND LICENSE
353              
354             This software is copyright (c) 2021 by Amazon Digital Services, Leon Brocard, Brad Fitzpatrick, Pedro Figueiredo, Rusty Conover, Branislav Zahradník.
355              
356             This is free software; you can redistribute it and/or modify it under
357             the same terms as the Perl 5 programming language system itself.
358              
359             =cut