File Coverage

blib/lib/Paws/Net/V2Signature.pm
Criterion Covered Total %
statement 21 69 30.4
branch 0 18 0.0
condition 0 6 0.0
subroutine 7 12 58.3
pod 0 3 0.0
total 28 108 25.9


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;