File Coverage

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

linestmtbrancondsubpodtimecode
1
4
4
4
236580
5
104
use strict;
2
4
4
4
13
4
190
use warnings;
3package Net::Amazon::SignatureVersion4;
4{
5  $Net::Amazon::SignatureVersion4::VERSION = '0.003';
6}
7
4
4
4
1992
6551235
95
use MooseX::App qw(Config);
8
4
4
4
6500498
10095
372
use Digest::SHA qw(sha256_hex hmac_sha256_hex hmac_sha256 hmac_sha256_base64);
9
4
4
4
1272
12811
97
use POSIX qw(strftime);
10
4
4
4
5033
34733
153
use URI::Encode;
11
4
4
4
966
9471
259
use HTTP::Date;
12
4
4
4
92
15
1857
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
26118
    my $self=shift;
79
30
2110
    my $request=$self->get_request();
80
30
71
    $request->header( Authorization => $self->get_authorization() );
81
30
3662
    return $request
82
83}
84
85sub get_authorization{
86
60
25380
    my $self=shift;
87
60
141
    my %dk=$self->get_derived_signing_key();
88
60
143
    my $sts=$self->get_string_to_sign();
89
60
185
    $sts=~tr/\r//d;
90
60
1090
    my $signature=hmac_sha256_hex($sts,$dk{'kSigning'});
91
60
3557
    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
116
    my $self=shift;
96
61
109
    $self->get_canonical_request(); # This is a hack to get the date set before using it to derive the signing key.
97
61
108
    my %rv=();
98
61
3661
    $rv{'kSecret'}="AWS4".$self->get_Secret_Access_Key();
99    #say("kSecret: ".unpack('H*',$rv{'kSecret'}));
100
61
3429
    $rv{'kDate'}=hmac_sha256($self->get_date_stamp(),$rv{'kSecret'});
101    #say("kDate: ".unpack('H*',$rv{'kDate'}));
102
61
3358
    $rv{'kRegion'}=hmac_sha256($self->get_region(),$rv{'kDate'});
103    #say("kRegion: ".unpack('H*',$rv{'kRegion'}));
104
61
3362
    $rv{'kService'}=hmac_sha256($self->get_service(),$rv{'kRegion'});
105    #say("kService: ".unpack('H*',$rv{'kService'}));
106
61
560
    $rv{'kSigning'}=hmac_sha256("aws4_request",$rv{'kService'});
107    #say("kSigning: ".unpack('H*',$rv{'kSigning'}));
108
61
421
    return %rv;
109}
110sub get_string_to_sign{
111
90
24379
    my $self=shift;
112
113
90
173
    my $creq=$self->get_canonical_request();
114
90
180
    $creq=~tr/\r//d;
115
90
4831
    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
1231
    my $self=shift;
125
4
4
4
1763
16739
3283
    use Data::Dumper;
126
127
181
216
    my $method;
128
181
262
    my $full_uri="";
129
181
175
    my $version;
130
181
198
    my $canonical_query_string="";
131
181
298
    my %headers=();
132
133
181
10872
    foreach my $name ( $self->get_request()->header_field_names() ){
134
406
37988
        my @value=$self->get_request()->header($name);
135
406
34266
        next unless (defined $name & defined $value[0]);
136
406
761
        if (lc($name) eq 'date'){
137
181
4905
            my $time=str2time($value[0]);
138
181
37554
            $self->set_date_stamp(strftime("%Y%m%d", gmtime($time)));
139
181
15092
            $self->set_time(strftime("%Y%m%dT%H%M%SZ",gmtime($time)));
140
141        }
142
406
668
        foreach my $value (@value){
143
436
1559
            local $/ = " ";
144
436
464
            chomp($value);
145
436
760
            if (defined $headers{lc($name)}){
146
30
30
16
99
                push @{$headers{lc($name)}}, $value;
147            }else{
148
406
2014
                $headers{lc($name)}=[$value ];
149            }
150        }
151    }
152
181
10265
    $full_uri=$self->get_request()->uri();
153
181
11012
    $full_uri =~ s@^(http|https)://.*?/@/@;
154
181
10850
    if ($full_uri=~m/(.*?)\?(.*)/){
155
60
2541
        $full_uri=$1;
156
60
106
        $canonical_query_string=$2;
157    }
158
181
4230
    my @canonical_query_list;
159
181
337
    if ( defined $canonical_query_string){
160
181
451
        if ($canonical_query_string=~m/(.*?)\s.*/){
161
0
0
            $canonical_query_string=$1
162        }
163
181
474
        @canonical_query_list=split(/\&/,$canonical_query_string);
164    }
165
181
187
    $canonical_query_string="";
166
181
395
    foreach my $param (sort @canonical_query_list){
167
84
268
        (my $name, my $value)=split(/=/, $param);
168
84
194
        $name="" unless (defined $name);
169
84
132
        $value="" unless (defined $value);
170
84
138
        $canonical_query_string=$canonical_query_string._encode($name)."="._encode($value)."&";
171    }
172
181
473
    $canonical_query_string=substr($canonical_query_string, 0, -1) unless ($canonical_query_string eq "");
173
181
2925
    $full_uri=~tr/\///s;
174
181
4489
    my $ends_in_slash=0;
175
181
346
    if ($full_uri=~m/\w\/$/){
176
6
6
        $ends_in_slash=1;
177    }
178
181
503
    my @uri_source=split /\//, $full_uri;
179
181
164
    my @uri_stack;
180
181
265
    foreach my $path_component (@uri_source){
181
135
232
        if ($path_component =~ m/^\.$/){
182
12
123
            sleep 0;
183        }elsif ($path_component =~ m/^..$/){
184
18
18
            pop @uri_stack;
185        }else{
186
105
130
            push @uri_stack, $path_component;
187        }
188    }
189
181
193
    $full_uri="/";
190
181
225
    foreach my $path_component (@uri_stack){
191
87
97
        $full_uri=$full_uri."$path_component/";
192    }
193
181
174
    $full_uri=~tr/\///s;
194
181
377
    chop $full_uri unless ( $full_uri eq "/" );
195
181
261
    if ($ends_in_slash){
196
6
6
        $full_uri=$full_uri."/";
197    }
198
181
164
    my $CanonicalHeaders="";
199
181
153
    my $SignedHeaders="";
200
181
622
    foreach my $header ( sort keys %headers ){
201
406
487
        $CanonicalHeaders=$CanonicalHeaders.lc($header).':';
202
406
406
318
533
        foreach my $element(sort @{$headers{$header}}){
203
436
628
            $CanonicalHeaders=$CanonicalHeaders.($element).",";
204        }
205
406
473
        $CanonicalHeaders=substr($CanonicalHeaders, 0, -1);
206
406
310
        $CanonicalHeaders=$CanonicalHeaders."\r\n";
207
406
450
        $SignedHeaders=$SignedHeaders.lc($header).";";
208   }
209
210
181
247
    $SignedHeaders=substr($SignedHeaders, 0, -1);
211
181
11168
    $self->set_signed_headers($SignedHeaders);
212
181
9738
    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
10946
    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
5307
    my $encoder = URI::Encode->new();
225
168
146776
    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
4781
    $rv=$encoder->encode($rv);
229
168
19915
    $rv=~s/\+/\%20/g;
230
168
201
    $rv=~s/\//\%2F/g;
231
168
174
    $rv=~s/\,/\%2C/g;
232
168
147
    $rv=~s/\?/\%3F/g;
233
168
143
    $rv=~s/\;/\%3B/g;
234
168
135
    $rv=~s/\:/\%3A/g;
235
168
124
    $rv=~s/\]/\%5D/g;
236
168
131
    $rv=~s/\[/\%5B/g;
237
168
147
    $rv=~s/\@/\%40/g;
238
168
178
    $rv=~s/\#/\%23/g;
239
168
141
    $rv=~s/\$/\%24/g;
240# $rv=~s///g;
241
168
23809
    return $rv;
242}
2431;
244