line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::Amazon::Signature::V4; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
68713
|
use strict; |
|
2
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
58
|
|
4
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
66
|
|
5
|
2
|
|
|
2
|
|
1063
|
use sort 'stable'; |
|
2
|
|
|
|
|
1190
|
|
|
2
|
|
|
|
|
11
|
|
6
|
|
|
|
|
|
|
|
7
|
2
|
|
|
2
|
|
1099
|
use Digest::SHA qw/sha256_hex hmac_sha256 hmac_sha256_hex/; |
|
2
|
|
|
|
|
6125
|
|
|
2
|
|
|
|
|
162
|
|
8
|
2
|
|
|
2
|
|
1139
|
use Time::Piece (); |
|
2
|
|
|
|
|
23754
|
|
|
2
|
|
|
|
|
59
|
|
9
|
2
|
|
|
2
|
|
2761
|
use URI::Escape; |
|
2
|
|
|
|
|
2989
|
|
|
2
|
|
|
|
|
3671
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $ALGORITHM = 'AWS4-HMAC-SHA256'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=head1 NAME |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
Net::Amazon::Signature::V4 - Implements the Amazon Web Services signature version 4, AWS4-HMAC-SHA256 |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 VERSION |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
Version 0.20 |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=cut |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our $VERSION = '0.20'; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 SYNOPSIS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
use Net::Amazon::Signature::V4; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
my $sig = Net::Amazon::Signature::V4->new( $access_key_id, $secret, $endpoint, $service ); |
31
|
|
|
|
|
|
|
my $req = HTTP::Request->parse( $request_string ); |
32
|
|
|
|
|
|
|
my $signed_req = $sig->sign( $req ); |
33
|
|
|
|
|
|
|
... |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head1 DESCRIPTION |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
This module signs an HTTP::Request to Amazon Web Services by appending an Authorization header. Amazon Web Services signature version 4, AWS4-HMAC-SHA256, is used. |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
The primary purpose of this module is to be used by Net::Amazon::Glacier. |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=head1 METHODS |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head2 new |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my $sig = Net::Amazon::Signature::V4->new( $access_key_id, $secret, $endpoint, $service ); |
46
|
|
|
|
|
|
|
my $sig = Net::Amazon::Signature::V4->new({ |
47
|
|
|
|
|
|
|
access_key_id => $access_key_id, |
48
|
|
|
|
|
|
|
secret => $secret, |
49
|
|
|
|
|
|
|
endpoint => $endpoint, |
50
|
|
|
|
|
|
|
service => $service, |
51
|
|
|
|
|
|
|
}); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
Constructs the signature object, which is used to sign requests. |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
Note that the access key ID is an alphanumeric string, not your account ID. The endpoint could be "eu-west-1", and the service could be "glacier". |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
Since version 0.20, parameters can be passed in a hashref. The keys C, C, C, and C are required. |
58
|
|
|
|
|
|
|
C, if passed, will be applied to each signed request as the C header. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=cut |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub new { |
63
|
1
|
|
|
1
|
1
|
897
|
my $class = shift; |
64
|
1
|
|
|
|
|
3
|
my $self = {}; |
65
|
1
|
50
|
33
|
|
|
7
|
if (@_ == 1 and ref $_[0] eq 'HASH') { |
66
|
0
|
|
|
|
|
0
|
@$self{keys %{$_[0]}} = values %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
67
|
|
|
|
|
|
|
} else { |
68
|
1
|
|
|
|
|
5
|
@$self{qw(access_key_id secret endpoint service)} = @_; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
# The URI should not be double escaped for the S3 service |
71
|
1
|
50
|
|
|
|
6
|
$self->{no_escape_uri} = ( lc($self->{service}) eq 's3' ) ? 1 : 0; |
72
|
1
|
|
|
|
|
3
|
bless $self, $class; |
73
|
1
|
|
|
|
|
3
|
return $self; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=head2 sign |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my $signed_request = $sig->sign( $request ); |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Signs a request with your credentials by appending the Authorization header. $request should be an HTTP::Request. The signed request is returned. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=cut |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub sign { |
85
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $request ) = @_; |
86
|
0
|
|
|
|
|
0
|
my $authz = $self->_authorization( $request ); |
87
|
0
|
|
|
|
|
0
|
$request->header( Authorization => $authz ); |
88
|
0
|
|
|
|
|
0
|
return $request; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# _headers_to_sign: |
92
|
|
|
|
|
|
|
# Return the sorted lower case headers as required by the generation of canonical headers |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub _headers_to_sign { |
95
|
124
|
|
|
124
|
|
182
|
my $req = shift; |
96
|
|
|
|
|
|
|
|
97
|
124
|
|
|
|
|
281
|
return sort { $a cmp $b } map { lc } $req->headers->header_field_names; |
|
616
|
|
|
|
|
1112
|
|
|
524
|
|
|
|
|
5441
|
|
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# _canonical_request: |
101
|
|
|
|
|
|
|
# Construct the canonical request string from an HTTP::Request. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub _canonical_request { |
104
|
93
|
|
|
93
|
|
46766
|
my ( $self, $req ) = @_; |
105
|
|
|
|
|
|
|
|
106
|
93
|
|
|
|
|
593
|
my $creq_method = $req->method; |
107
|
|
|
|
|
|
|
|
108
|
93
|
100
|
|
|
|
1061
|
my ( $creq_canonical_uri, $creq_canonical_query_string ) = |
109
|
|
|
|
|
|
|
( $req->uri =~ m@([^?]*)\?(.*)$@ ) |
110
|
|
|
|
|
|
|
? ( $1, $2 ) |
111
|
|
|
|
|
|
|
: ( $req->uri, '' ); |
112
|
93
|
|
|
|
|
1864
|
$creq_canonical_uri =~ s@^https?://[^/]*/?@/@; |
113
|
93
|
|
|
|
|
432
|
$creq_canonical_uri = $self->_simplify_uri( $creq_canonical_uri ); |
114
|
93
|
|
|
|
|
247
|
$creq_canonical_query_string = _sort_query_string( $creq_canonical_query_string ); |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# Ensure Host header is present as its required |
117
|
93
|
50
|
|
|
|
253
|
if (!$req->header('host')) { |
118
|
0
|
|
|
|
|
0
|
$req->header('Host' => $req->uri->host); |
119
|
|
|
|
|
|
|
} |
120
|
93
|
|
|
|
|
4278
|
my $creq_payload_hash = $req->header('x-amz-content-sha256'); |
121
|
93
|
100
|
|
|
|
4258
|
if (!$creq_payload_hash) { |
122
|
31
|
|
|
|
|
92
|
$creq_payload_hash = sha256_hex($req->content); |
123
|
|
|
|
|
|
|
# X-Amz-Content-Sha256 must be specified now |
124
|
31
|
|
|
|
|
629
|
$req->header('X-Amz-Content-Sha256' => $creq_payload_hash); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# There's a bug in AMS4 which causes requests without x-amz-date set to be rejected |
128
|
|
|
|
|
|
|
# so we always add one if its not present. |
129
|
93
|
|
|
|
|
1812
|
my $amz_date = $req->header('x-amz-date'); |
130
|
93
|
100
|
|
|
|
3974
|
if (!$amz_date) { |
131
|
31
|
|
|
|
|
86
|
$req->header('X-Amz-Date' => _req_timepiece($req)->strftime('%Y%m%dT%H%M%SZ')); |
132
|
|
|
|
|
|
|
} |
133
|
93
|
50
|
33
|
|
|
5738
|
if (defined $self->{security_token} and !defined $req->header('X-Amz-Security-Token')) { |
134
|
0
|
|
|
|
|
0
|
$req->header('X-Amz-Security-Token' => $self->{security_token}); |
135
|
|
|
|
|
|
|
} |
136
|
93
|
|
|
|
|
194
|
my @sorted_headers = _headers_to_sign( $req ); |
137
|
|
|
|
|
|
|
my $creq_canonical_headers = join '', |
138
|
|
|
|
|
|
|
map { |
139
|
93
|
|
|
|
|
241
|
sprintf "%s:%s\x0a", |
140
|
|
|
|
|
|
|
lc, |
141
|
393
|
|
|
|
|
1146
|
join ',', sort {$a cmp $b } _trim_whitespace($req->header($_) ) |
|
24
|
|
|
|
|
66
|
|
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
@sorted_headers; |
144
|
93
|
|
|
|
|
219
|
my $creq_signed_headers = join ';', map {lc} @sorted_headers; |
|
393
|
|
|
|
|
767
|
|
145
|
93
|
|
|
|
|
334
|
my $creq = join "\x0a", |
146
|
|
|
|
|
|
|
$creq_method, $creq_canonical_uri, $creq_canonical_query_string, |
147
|
|
|
|
|
|
|
$creq_canonical_headers, $creq_signed_headers, $creq_payload_hash; |
148
|
93
|
|
|
|
|
296
|
return $creq; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# _string_to_sign |
152
|
|
|
|
|
|
|
# Construct the string to sign. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub _string_to_sign { |
155
|
62
|
|
|
62
|
|
21203
|
my ( $self, $req ) = @_; |
156
|
62
|
|
|
|
|
131
|
my $dt = _req_timepiece( $req ); |
157
|
62
|
|
|
|
|
3426
|
my $creq = $self->_canonical_request($req); |
158
|
62
|
|
|
|
|
208
|
my $sts_request_date = $dt->strftime( '%Y%m%dT%H%M%SZ' ); |
159
|
62
|
|
|
|
|
2544
|
my $sts_credential_scope = join '/', $dt->strftime('%Y%m%d'), $self->{endpoint}, $self->{service}, 'aws4_request'; |
160
|
62
|
|
|
|
|
2143
|
my $sts_creq_hash = sha256_hex( $creq ); |
161
|
|
|
|
|
|
|
|
162
|
62
|
|
|
|
|
192
|
my $sts = join "\x0a", $ALGORITHM, $sts_request_date, $sts_credential_scope, $sts_creq_hash; |
163
|
62
|
|
|
|
|
218
|
return $sts; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# _authorization |
167
|
|
|
|
|
|
|
# Construct the authorization string |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub _authorization { |
170
|
31
|
|
|
31
|
|
21025
|
my ( $self, $req ) = @_; |
171
|
|
|
|
|
|
|
|
172
|
31
|
|
|
|
|
79
|
my $dt = _req_timepiece( $req ); |
173
|
31
|
|
|
|
|
1904
|
my $sts = $self->_string_to_sign( $req ); |
174
|
31
|
|
|
|
|
83
|
my $k_date = hmac_sha256( $dt->strftime('%Y%m%d'), 'AWS4' . $self->{secret} ); |
175
|
31
|
|
|
|
|
1217
|
my $k_region = hmac_sha256( $self->{endpoint}, $k_date ); |
176
|
31
|
|
|
|
|
237
|
my $k_service = hmac_sha256( $self->{service}, $k_region ); |
177
|
31
|
|
|
|
|
221
|
my $k_signing = hmac_sha256( 'aws4_request', $k_service ); |
178
|
|
|
|
|
|
|
|
179
|
31
|
|
|
|
|
279
|
my $authz_signature = hmac_sha256_hex( $sts, $k_signing ); |
180
|
31
|
|
|
|
|
87
|
my $authz_credential = join '/', $self->{access_key_id}, $dt->strftime('%Y%m%d'), $self->{endpoint}, $self->{service}, 'aws4_request'; |
181
|
31
|
|
|
|
|
831
|
my $authz_signed_headers = join ';', _headers_to_sign( $req ); |
182
|
|
|
|
|
|
|
|
183
|
31
|
|
|
|
|
126
|
my $authz = "$ALGORITHM Credential=$authz_credential,SignedHeaders=$authz_signed_headers,Signature=$authz_signature"; |
184
|
31
|
|
|
|
|
110
|
return $authz; |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
=head1 AUTHOR |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
Tim Nordenfur, C<< >> |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
Maintained by Dan Book, C<< >> |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
=cut |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub _simplify_uri { |
197
|
93
|
|
|
93
|
|
143
|
my $self = shift; |
198
|
93
|
|
|
|
|
153
|
my $orig_uri = shift; |
199
|
93
|
|
|
|
|
217
|
my @parts = split /\//, $orig_uri; |
200
|
93
|
|
|
|
|
471
|
my @simple_parts = (); |
201
|
93
|
|
|
|
|
204
|
for my $part ( @parts ) { |
202
|
78
|
100
|
100
|
|
|
492
|
if ( $part eq '' || $part eq '.' ) { |
|
|
100
|
|
|
|
|
|
203
|
|
|
|
|
|
|
} elsif ( $part eq '..' ) { |
204
|
9
|
|
|
|
|
16
|
pop @simple_parts; |
205
|
|
|
|
|
|
|
} else { |
206
|
33
|
50
|
|
|
|
69
|
if ( $self->{no_escape_uri} ) { |
207
|
0
|
|
|
|
|
0
|
push @simple_parts, $part; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
else { |
210
|
33
|
|
|
|
|
79
|
push @simple_parts, uri_escape($part); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
} |
214
|
93
|
|
|
|
|
545
|
my $simple_uri = '/' . join '/', @simple_parts; |
215
|
93
|
100
|
100
|
|
|
345
|
$simple_uri .= '/' if $orig_uri =~ m@/$@ && $simple_uri !~ m@/$@; |
216
|
93
|
|
|
|
|
695
|
return $simple_uri; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
sub _sort_query_string { |
219
|
93
|
100
|
|
93
|
|
227
|
return '' unless $_[0]; |
220
|
30
|
|
|
|
|
49
|
my @params; |
221
|
30
|
|
|
|
|
78
|
for my $param ( split /&/, $_[0] ) { |
222
|
|
|
|
|
|
|
my ( $key, $value ) = |
223
|
42
|
|
|
|
|
103
|
map { tr/+/ /; uri_escape( uri_unescape( $_ ) ) } # escape all non-unreserved chars |
|
78
|
|
|
|
|
805
|
|
|
78
|
|
|
|
|
174
|
|
224
|
|
|
|
|
|
|
split /=/, $param; |
225
|
42
|
100
|
|
|
|
1008
|
push @params, [$key, (defined $value ? $value : '')]; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
return join '&', |
228
|
42
|
|
|
|
|
154
|
map { join '=', @$_ } |
229
|
30
|
50
|
|
|
|
89
|
sort { ( $a->[0] cmp $b->[0] ) || ( $a->[1] cmp $b->[1] ) } |
|
12
|
|
|
|
|
50
|
|
230
|
|
|
|
|
|
|
@params; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
sub _trim_whitespace { |
233
|
393
|
|
|
393
|
|
15420
|
return map { my $str = $_; $str =~ s/^\s*//; $str =~ s/\s*$//; $str } @_; |
|
408
|
|
|
|
|
621
|
|
|
408
|
|
|
|
|
1633
|
|
|
408
|
|
|
|
|
2533
|
|
|
408
|
|
|
|
|
2322
|
|
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
sub _str_to_timepiece { |
236
|
124
|
|
|
124
|
|
228
|
my $date = shift; |
237
|
124
|
100
|
|
|
|
650
|
if ( $date =~ m/^\d{8}T\d{6}Z$/ ) { |
238
|
|
|
|
|
|
|
# assume basic ISO 8601, as demanded by AWS |
239
|
93
|
|
|
|
|
415
|
return Time::Piece->strptime($date, '%Y%m%dT%H%M%SZ'); |
240
|
|
|
|
|
|
|
} else { |
241
|
|
|
|
|
|
|
# assume the format given in the AWS4 test suite |
242
|
31
|
|
|
|
|
155
|
$date =~ s/^.{5}//; # remove weekday, as Amazon's test suite contains internally inconsistent dates |
243
|
31
|
|
|
|
|
171
|
return Time::Piece->strptime($date, '%d %b %Y %H:%M:%S %Z'); |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
sub _req_timepiece { |
247
|
124
|
|
|
124
|
|
225
|
my $req = shift; |
248
|
124
|
|
|
|
|
345
|
my $x_date = $req->header('X-Amz-Date'); |
249
|
124
|
|
66
|
|
|
5547
|
my $date = $x_date || $req->header('Date'); |
250
|
124
|
50
|
|
|
|
1453
|
if (!$date) { |
251
|
|
|
|
|
|
|
# No date set by the caller so set one up |
252
|
0
|
|
|
|
|
0
|
my $piece = Time::Piece::gmtime; |
253
|
0
|
|
|
|
|
0
|
$req->date($piece->epoch); |
254
|
0
|
|
|
|
|
0
|
return $piece |
255
|
|
|
|
|
|
|
} |
256
|
124
|
|
|
|
|
252
|
return _str_to_timepiece($date); |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=head1 BUGS |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
262
|
|
|
|
|
|
|
the web interface at L. I will be notified, and then you'll |
263
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
=head1 SUPPORT |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
perldoc Net::Amazon::Signature::V4 |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
You can also look for information at: |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=over 4 |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker (report bugs here) |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
L |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=item * Source on GitHub |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
L |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=item * Search CPAN |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
L |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=back |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
This software is copyright (c) 2012 by Tim Nordenfur. |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
298
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
=cut |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
1; # End of Net::Amazon::Signature::V4 |