view release on metacpan or  search on metacpan

t/security.t  view on Meta::CPAN

use v5.24;
use Test2::V0;
use FindBin '$Bin';
use lib "$Bin/../lib";
use experimental 'signatures';
use Data::Dumper ();
use File::Temp ();
use AWS::Signature::V4;

my %cred = (access_key_id => 'AKID', secret_access_key => 'SECRET');
my $s3  = AWS::Signature::V4->new(service => 's3', region => 'r', credentials => {%cred});
my $url = 'https://b.s3.amazonaws.com/k';

sub bad_request ($re) {
   object { prop blessed => 'Ouch'; call code => 400; call message => match $re };
}

sub dump_of ($x) {
   local $Data::Dumper::Deparse = 0;
   Data::Dumper->new([$x])->Useqq(1)->Dump;
}

subtest 'header names and values are validated' => sub {
   for my $value ("a\r\nX-Injected: 1", "a\nb", "a\rb", "a\0b") {
      my $shown = $value =~ s/([^ -~])/sprintf '\\x%02X', ord $1/ger;
      is dies { $s3->sign(method => 'GET', url => $url, headers => {'X-V' => $value}) },
         bad_request(qr/header/), "value $shown rejected";
   }
   for my $name ("x-n:1\nfoo", 'x n', 'x:n', '', "x\x{e9}") {
      my $shown = $name =~ s/([^ -~])/sprintf '\\x%02X', ord $1/ger;
      is dies { $s3->sign(method => 'GET', url => $url, headers => {$name => 'v'}) },
         bad_request(qr/header/), "name '$shown' rejected";
   }
   ok lives { $s3->sign(method => 'GET', url => $url,
      headers => {"X-Ok_1.a!#\$%&'*+^`|~" => "tab\there, spaces  ok"}) },
      'valid token names and values with tabs and spaces are fine';
   is dies { $s3->presign(url => $url, headers => {'X-V' => "a\nb"}) },
      bad_request(qr/header/), 'presign too';
};

subtest 'the derived signing key is not exposed' => sub {
   my $r = $s3->sign(method => 'PUT', url => $url, time => 0,
      streaming => 1, decoded_content_length => 1);
   my $ck = $r->{chunker};
   ok !$ck->can('key'), 'no key accessor';
   ok !$ck->can('previous'), 'no previous accessor';
   my $key = unpack 'H*', AWS::Signature::V4::Credentials->new(%cred)
      ->signing_key($r->{scope});
   unlike dump_of($r), qr/\Q$key\E/, 'the hex key is not in a dump of the result';
   my $raw = pack 'H*', $key;
   unlike dump_of($r), qr/\Q@{[ quotemeta $raw ]}\E/, 'nor the raw key';
   like $ck->chunk('x'), qr/\A1;chunk-signature=[0-9a-f]{64}\r\nx\r\n\z/, 'chunks are still signed';
};

subtest 'presign refuses authentication parameters in the url' => sub {
   for my $param (qw<
      X-Amz-Algorithm X-Amz-Credential X-Amz-Date X-Amz-Expires
      X-Amz-SignedHeaders X-Amz-Signature X-Amz-Security-Token
      X-Amz-X509 X-Amz-X509-Chain x-amz-signature X-AMZ-EXPIRES
   >) {
      is dies { $s3->presign(url => "$url?$param=1") },
         bad_request(qr/\Q$param\E/i), "$param rejected";
   }
   is dies { $s3->presign(url => "$url?X%2DAmz%2DCredential=1") },
      bad_request(qr/credential/i), 'also when percent-encoded';
   ok lives { $s3->presign(url => "$url?X-Amz-Meta-Foo=1&versionId=3") },
      'other parameters are fine';
};

subtest 'host is always signed' => sub {
   my $r = $s3->sign(method => 'GET', url => $url, time => 0,