line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Paws::Net::V2Signature; |
2
|
4
|
|
|
4
|
|
2969
|
use Moose::Role; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
29
|
|
3
|
4
|
|
|
4
|
|
17755
|
use Digest::SHA qw(hmac_sha256); |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
206
|
|
4
|
4
|
|
|
4
|
|
1088
|
use MIME::Base64 qw(encode_base64); |
|
4
|
|
|
|
|
2174
|
|
|
4
|
|
|
|
|
203
|
|
5
|
4
|
|
|
4
|
|
27
|
use Carp; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
179
|
|
6
|
4
|
|
|
4
|
|
20
|
use URI; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
81
|
|
7
|
4
|
|
|
4
|
|
17
|
use POSIX qw/strftime/; |
|
4
|
|
|
|
|
258
|
|
|
4
|
|
|
|
|
32
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
sub BUILD { |
10
|
28
|
|
|
28
|
0
|
35698
|
my $self = shift; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# These calls are here so that when you construct |
13
|
|
|
|
|
|
|
# the object the endpoint information and the _region_for_signature |
14
|
|
|
|
|
|
|
# are calculated during construction. This is to avoid the fact that |
15
|
|
|
|
|
|
|
# these attributes are lazy (because they depend on other attributes) |
16
|
|
|
|
|
|
|
# and they don't get used until the first method is called, so if |
17
|
|
|
|
|
|
|
# they are incorrect, they don't throw until the first method is called. |
18
|
|
|
|
|
|
|
# It's much better to have them throw when $paws->service('...') is called |
19
|
|
|
|
|
|
|
# as this is the point where the user had specified "incorrect" information, |
20
|
|
|
|
|
|
|
# instead of the problem happening in the first method call. |
21
|
28
|
|
|
|
|
770
|
$self->endpoint; |
22
|
28
|
|
|
|
|
727
|
$self->_region_for_signature; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
has 'base_url' => ( |
26
|
|
|
|
|
|
|
is => 'ro', |
27
|
|
|
|
|
|
|
required => 1, |
28
|
|
|
|
|
|
|
lazy => 1, |
29
|
|
|
|
|
|
|
default => sub { |
30
|
|
|
|
|
|
|
sprintf 'https://%s', $_[0]->endpoint_host; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
has '_base_url_host' => ( |
35
|
|
|
|
|
|
|
is => 'ro', |
36
|
|
|
|
|
|
|
required => 1, |
37
|
|
|
|
|
|
|
lazy => 1, |
38
|
|
|
|
|
|
|
default => sub { |
39
|
|
|
|
|
|
|
($_[0]->_split_url($_[0]->base_url))[1] |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
); |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
# Lifted off HTTP::Tiny |
44
|
|
|
|
|
|
|
sub _split_url { |
45
|
0
|
|
|
0
|
|
|
my $url = pop; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# URI regex adapted from the URI module |
48
|
0
|
0
|
|
|
|
|
my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> |
49
|
|
|
|
|
|
|
or die(qq/Cannot parse URL: '$url'\n/); |
50
|
|
|
|
|
|
|
|
51
|
0
|
|
|
|
|
|
$scheme = lc $scheme; |
52
|
0
|
0
|
|
|
|
|
$path_query = "/$path_query" unless $path_query =~ m<\A/>; |
53
|
|
|
|
|
|
|
|
54
|
0
|
|
|
|
|
|
my $auth = ''; |
55
|
0
|
0
|
|
|
|
|
if ( (my $i = index $host, '@') != -1 ) { |
56
|
|
|
|
|
|
|
# user:pass@host |
57
|
0
|
|
|
|
|
|
$auth = substr $host, 0, $i, ''; # take up to the @ for auth |
58
|
0
|
|
|
|
|
|
substr $host, 0, 1, ''; # knock the @ off the host |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# userinfo might be percent escaped, so recover real auth info |
61
|
0
|
|
|
|
|
|
$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
|
0
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
} |
63
|
0
|
0
|
0
|
|
|
|
my $port = $host =~ s/:(\d*)\z// && length $1 ? $1 |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
64
|
|
|
|
|
|
|
: $scheme eq 'http' ? 80 |
65
|
|
|
|
|
|
|
: $scheme eq 'https' ? 443 |
66
|
|
|
|
|
|
|
: undef; |
67
|
|
|
|
|
|
|
|
68
|
0
|
0
|
|
|
|
|
return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub sign { |
72
|
0
|
|
|
0
|
0
|
|
my ($self, $request) = @_; |
73
|
|
|
|
|
|
|
|
74
|
0
|
|
|
|
|
|
$request->parameters->{ SignatureVersion } = "2"; |
75
|
0
|
|
|
|
|
|
$request->parameters->{ SignatureMethod } = "HmacSHA256"; |
76
|
0
|
|
0
|
|
|
|
$request->parameters->{ Timestamp } //= strftime("%Y-%m-%dT%H:%M:%SZ",gmtime); |
77
|
0
|
|
|
|
|
|
$request->parameters->{ AWSAccessKeyId } = $self->access_key; |
78
|
|
|
|
|
|
|
|
79
|
0
|
0
|
|
|
|
|
if ($self->session_token) { |
80
|
0
|
|
|
|
|
|
$request->parameters->{ SecurityToken } = $self->session_token; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
0
|
|
|
|
|
|
my %sign_hash = %{ $request->parameters }; |
|
0
|
|
|
|
|
|
|
84
|
0
|
|
|
|
|
|
my $sign_this = "POST\n"; |
85
|
0
|
|
|
|
|
|
$sign_this .= $self->_base_url_host . "\n"; |
86
|
0
|
|
|
|
|
|
$sign_this .= "/\n"; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
|
89
|
0
|
|
|
|
|
|
$sign_this .= $self->www_form_urlencode(\%sign_hash); |
90
|
|
|
|
|
|
|
|
91
|
0
|
|
|
|
|
|
my $encoded = encode_base64(hmac_sha256($sign_this, $self->secret_key), ''); |
92
|
|
|
|
|
|
|
|
93
|
0
|
|
|
|
|
|
$request->parameters->{ Signature } = $encoded; |
94
|
|
|
|
|
|
|
|
95
|
0
|
|
|
|
|
|
$request->content($self->generate_content_from_parameters($request)); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub www_form_urlencode { |
100
|
0
|
|
|
0
|
0
|
|
my ($self, $data) = @_; |
101
|
|
|
|
|
|
|
|
102
|
0
|
|
|
|
|
|
my @params = %$data; |
103
|
|
|
|
|
|
|
|
104
|
0
|
|
|
|
|
|
my @terms; |
105
|
0
|
|
|
|
|
|
while( @params ) { |
106
|
0
|
|
|
|
|
|
my ($key, $value) = splice(@params, 0, 2); |
107
|
0
|
0
|
|
|
|
|
if ( ref $value eq 'ARRAY' ) { |
108
|
0
|
|
|
|
|
|
unshift @params, map { $key => $_ } @$value; |
|
0
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
else { |
111
|
0
|
|
|
|
|
|
push @terms, join("=", map { $self->_uri_escape($_) } $key, $value); |
|
0
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
0
|
|
|
|
|
|
return join("&", sort @terms ); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# URI escaping adapted from URI::Escape |
119
|
|
|
|
|
|
|
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 |
120
|
|
|
|
|
|
|
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP |
121
|
|
|
|
|
|
|
our %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; |
122
|
|
|
|
|
|
|
our $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
sub _uri_escape { |
125
|
0
|
|
|
0
|
|
|
my ($self, $str) = @_; |
126
|
0
|
|
|
|
|
|
utf8::encode($str); |
127
|
0
|
|
|
|
|
|
$str =~ s/($unsafe_char)/$escapes{$1}/ge; |
|
0
|
|
|
|
|
|
|
128
|
0
|
|
|
|
|
|
$str =~ s/ /+/go; |
129
|
0
|
|
|
|
|
|
return $str; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub _request { |
133
|
0
|
|
|
0
|
|
|
my $self = shift; |
134
|
0
|
|
|
|
|
|
my $params = shift; |
135
|
|
|
|
|
|
|
|
136
|
0
|
|
|
|
|
|
return $self->ua->post_form( $self->base_url, $params ); |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
1; |