File Coverage

File:blib/lib/Net/Amazon/SignatureVersion4.pm
Coverage:96.0%

linestmtbrancondsubpodtimecode
1
4
4
4
245661
4
96
use strict;
2
4
4
4
10
6
208
use warnings;
3package Net::Amazon::SignatureVersion4;
4{
5  $Net::Amazon::SignatureVersion4::VERSION = '0.004';
6}
7
4
4
4
1971
6617090
110
use MooseX::App qw(Config);
8
4
4
4
6182229
9334
319
use Digest::SHA qw(sha256_hex hmac_sha256_hex hmac_sha256 hmac_sha256_base64);
9
4
4
4
1206
10085
95
use POSIX qw(strftime);
10
4
4
4
4598
33957
137
use URI::Encode;
11
4
4
4
868
9144
189
use HTTP::Date;
12
4
4
4
74
9
1643
use 5.010;
13
14# ABSTRACT: Signs requests using Amazon's Signature Version 4.
15
16
17option 'Access_Key_Id' => (
18    is => 'rw',
19    isa => 'Str',
20    reader => 'get_Access_Key_ID',
21    predicate => 'has_Access_Key_ID',
22    writer => 'set_Access_Key_ID',
23    );
24
25option 'Secret_Access_Key' => (
26    is => 'rw',
27    isa => 'Str',
28    reader => 'get_Secret_Access_Key',
29    predicate => 'has_Secret_Access_Key',
30    writer => 'set_Secret_Access_Key',
31    );
32
33option 'region' => (
34    is => 'rw',
35    isa => 'Str',
36    writer => 'set_region',
37    reader => 'get_region',
38    default => 'us-east-1',
39    );
40
41option 'request' => (
42    is => 'rw',
43    isa => 'Object',
44    writer => 'set_request',
45    reader => 'get_request',
46    );
47
48option 'service' => (
49    is => 'rw',
50    isa => 'Str',
51    writer => 'set_service',
52    reader => 'get_service',
53    );
54
55option 'time' => (
56    is => 'rw',
57    isa => 'Str',
58    writer => 'set_time',
59    reader => 'get_time',
60    );
61
62option 'date_stamp' => (
63    is => 'rw',
64    isa => 'Str',
65    writer => 'set_date_stamp',
66    reader => 'get_date_stamp',
67    );
68
69option 'signed_headers' => (
70    is => 'rw',
71    isa => 'Str',
72    writer => 'set_signed_headers',
73    reader => 'get_signed_headers',
74    );
75
76sub get_authorized_request{
77
78
30
23864
    my $self=shift;
79
30
1963
    my $request=$self->get_request();
80
30
68
    $request->header( Authorization => $self->get_authorization() );
81
30
3136
    return $request
82
83}
84
85sub get_authorization{
86
60
23148
    my $self=shift;
87
60
129
    my %dk=$self->get_derived_signing_key();
88
60
121
    my $sts=$self->get_string_to_sign();
89
60
152
    $sts=~tr/\r//d;
90
60
963
    my $signature=hmac_sha256_hex($sts,$dk{'kSigning'});
91
60
3324
    return "AWS4-HMAC-SHA256 Credential=".$self->get_Access_Key_ID()."/".$self->get_date_stamp()."/".$self->get_region()."/".$self->get_service()."/aws4_request, SignedHeaders=".$self->get_signed_headers().", Signature=$signature";
92}
93
94sub get_derived_signing_key{
95
61
89
    my $self=shift;
96
61
117
    $self->get_canonical_request(); # This is a hack to get the date set before using it to derive the signing key.
97
61
88
    my %rv=();
98
61
3114
    $rv{'kSecret'}="AWS4".$self->get_Secret_Access_Key();
99    #say("kSecret: ".unpack('H*',$rv{'kSecret'}));
100
61
2928
    $rv{'kDate'}=hmac_sha256($self->get_date_stamp(),$rv{'kSecret'});
101    #say("kDate: ".unpack('H*',$rv{'kDate'}));
102
61
2898
    $rv{'kRegion'}=hmac_sha256($self->get_region(),$rv{'kDate'});
103    #say("kRegion: ".unpack('H*',$rv{'kRegion'}));
104
61
2913
    $rv{'kService'}=hmac_sha256($self->get_service(),$rv{'kRegion'});
105    #say("kService: ".unpack('H*',$rv{'kService'}));
106
61
489
    $rv{'kSigning'}=hmac_sha256("aws4_request",$rv{'kService'});
107    #say("kSigning: ".unpack('H*',$rv{'kSigning'}));
108
61
348
    return %rv;
109}
110sub get_string_to_sign{
111
90
22632
    my $self=shift;
112
113
90
125
    my $creq=$self->get_canonical_request();
114
90
156
    $creq=~tr/\r//d;
115
90
4362
    my $StringToSign="AWS4-HMAC-SHA256\r\n".
116        $self->get_time()."\r\n".
117        $self->get_date_stamp()."/".
118        $self->get_region()."/".
119        $self->get_service()."/aws4_request\r\n".
120        sha256_hex($creq);
121}
122
123sub get_canonical_request{
124
181
1135
    my $self=shift;
125
4
4
4
1690
19036
3411
    use Data::Dumper;
126
127
181
163
    my $method;
128
181
213
    my $full_uri="";
129
181
139
    my $version;
130
181
204
    my $canonical_query_string="";
131
181
241
    my %headers=();
132
133
181
9800
    foreach my $name ( $self->get_request()->header_field_names() ){
134
406
33492
        my @value=$self->get_request()->header($name);
135
406
30594
        next unless (defined $name & defined $value[0]);
136
406
685
        if (lc($name) eq 'date'){
137
181
4355
            my $time=str2time($value[0]);
138
181
32433
            $self->set_date_stamp(strftime("%Y%m%d", gmtime($time)));
139
181
13121
            $self->set_time(strftime("%Y%m%dT%H%M%SZ",gmtime($time)));
140
141        }
142
406
568
        foreach my $value (@value){
143
436
1203
            local $/ = " ";
144
436
398
            chomp($value);
145
436
586
            if (defined $headers{lc($name)}){
146
30
30
25
91
                push @{$headers{lc($name)}}, $value;
147            }else{
148
406
1712
                $headers{lc($name)}=[$value ];
149            }
150        }
151    }
152
181
9045
    $full_uri=$self->get_request()->uri();
153
181
9997
    $full_uri =~ s@^(http|https)://.*?/@/@;
154
181
9456
    if ($full_uri=~m/(.*?)\?(.*)/){
155
60
2078
        $full_uri=$1;
156
60
94
        $canonical_query_string=$2;
157    }
158
181
3893
    my @canonical_query_list;
159
181
281
    if ( defined $canonical_query_string){
160
181
435
        if ($canonical_query_string=~m/(.*?)\s.*/){
161
0
0
            $canonical_query_string=$1
162        }
163
181
390
        @canonical_query_list=split(/\&/,$canonical_query_string);
164    }
165
181
149
    $canonical_query_string="";
166
181
352
    foreach my $param (sort @canonical_query_list){
167
84
225
        (my $name, my $value)=split(/=/, $param);
168
84
124
        $name="" unless (defined $name);
169
84
106
        $value="" unless (defined $value);
170
84
117
        $canonical_query_string=$canonical_query_string._encode($name)."="._encode($value)."&";
171    }
172
181
366
    $canonical_query_string=substr($canonical_query_string, 0, -1) unless ($canonical_query_string eq "");
173
181
2643
    $full_uri=~tr/\///s;
174
181
4101
    my $ends_in_slash=0;
175
181
273
    if ($full_uri=~m/\w\/$/){
176
6
6
        $ends_in_slash=1;
177    }
178
181
416
    my @uri_source=split /\//, $full_uri;
179
181
146
    my @uri_stack;
180
181
205
    foreach my $path_component (@uri_source){
181
135
234
        if ($path_component =~ m/^\.$/){
182
12
128
            sleep 0;
183        }elsif ($path_component =~ m/^..$/){
184
18
21
            pop @uri_stack;
185        }else{
186
105
151
            push @uri_stack, $path_component;
187        }
188    }
189
181
203
    $full_uri="/";
190
181
162
    foreach my $path_component (@uri_stack){
191
87
106
        $full_uri=$full_uri."$path_component/";
192    }
193
181
170
    $full_uri=~tr/\///s;
194
181
255
    chop $full_uri unless ( $full_uri eq "/" );
195
181
212
    if ($ends_in_slash){
196
6
5
        $full_uri=$full_uri."/";
197    }
198
181
141
    my $CanonicalHeaders="";
199
181
157
    my $SignedHeaders="";
200
181
485
    foreach my $header ( sort keys %headers ){
201
406
395
        $CanonicalHeaders=$CanonicalHeaders.lc($header).':';
202
406
406
259
479
        foreach my $element(sort @{$headers{$header}}){
203
436
554
            $CanonicalHeaders=$CanonicalHeaders.($element).",";
204        }
205
406
436
        $CanonicalHeaders=substr($CanonicalHeaders, 0, -1);
206
406
229
        $CanonicalHeaders=$CanonicalHeaders."\r\n";
207
406
421
        $SignedHeaders=$SignedHeaders.lc($header).";";
208   }
209
210
181
225
    $SignedHeaders=substr($SignedHeaders, 0, -1);
211
181
9606
    $self->set_signed_headers($SignedHeaders);
212
181
8530
    my $CanonicalRequest =
213        $self->get_request()->method() . "\r\n" .
214        $full_uri . "\r\n" .
215        $canonical_query_string . "\r\n" .
216        $CanonicalHeaders . "\r\n" .
217        $SignedHeaders . "\r\n" .
218        sha256_hex($self->get_request()->content());
219
181
9387
    return $CanonicalRequest;
220}
221
222sub _encode{
223    #This method is used to add some additional encodings that are not enforced by the URI::Encode module. AWS expects these.
224
168
4414
    my $encoder = URI::Encode->new();
225
168
116774
    my $rv=shift;
226# %20=%2F%2C%3F%3E%3C%60%22%3B%3A%5C%7C%5D%5B%7B%7D&%40%23%24%25%5E=
227# + =/ , ? %3E%3C%60%22; : %5C%7C] [ %7B%7D&@ # $ %25%5E=
228
168
3980
    $rv=$encoder->encode($rv);
229
168
16913
    $rv=~s/\+/\%20/g;
230
168
136
    $rv=~s/\//\%2F/g;
231
168
128
    $rv=~s/\,/\%2C/g;
232
168
114
    $rv=~s/\?/\%3F/g;
233
168
104
    $rv=~s/\;/\%3B/g;
234
168
102
    $rv=~s/\:/\%3A/g;
235
168
110
    $rv=~s/\]/\%5D/g;
236
168
107
    $rv=~s/\[/\%5B/g;
237
168
117
    $rv=~s/\@/\%40/g;
238
168
98
    $rv=~s/\#/\%23/g;
239
168
115
    $rv=~s/\$/\%24/g;
240# $rv=~s///g;
241
168
19455
    return $rv;
242}
2431;
244