File Coverage

blib/lib/Net/Amazon/S3/Policy.pm

Criterion	Covered	Total	%
statement	94	112	83.9
branch	25	44	56.8
condition	1	3	33.3
subroutine	23	26	88.4
pod	14	14	100.0
total	157	199	78.8

package Net::Amazon::S3::Policy;

use warnings;
use strict;
use version; our $VERSION = qv('0.1.6');

use Carp;
use English qw( -no_match_vars );
use JSON;
use Encode ();
use MIME::Base64 qw< decode_base64 >;

use Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( exact starts_with range );
our %EXPORT_TAGS = (all => \@EXPORT_OK,);

# Module implementation here
sub new {
   my $class = shift;
   my %args  = ref($_[0]) ? %{$_[0]} : @_;
   my $self  = bless {}, $class;

   if ($args{json}) {
      $self->parse($args{json});
   }
   else {
      $self->expiration($args{expiration}) if defined $args{expiration};
      $self->conditions([]);
      $self->add($_) for @{$args{conditions} || []};
   }

   return $self;
} ## end sub new

# Accessors
sub expiration {
   my $self     = shift;
   my $previous = $self->{expiration};
   if (@_) {
      my $time = shift;
      if ($time && $time =~ /\A \d+ \z/mxs) {
         my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
           gmtime($time);
         $time = sprintf "%04d-%02d-%02dT%02d:%02d:%02d.000Z",
           $year + 1900,
           $mon + 1, $mday, $hour, $min, $sec;
      } ## end if ($time && $time =~ ...
      $time ? ($self->{expiration} = $time) : delete $self->{expiration};
   } ## end if (@_)
   return $previous;
} ## end sub expiration

sub conditions {
   my $self     = shift;
   my $previous = $self->{conditions};

   if (@_) {
      $self->{conditions} = (scalar(@_) == 1) ? shift : [@_];
   }

   return $previous;
} ## end sub conditions

{    # try to understand rules

   sub _prepend_dollar {
      return substr($_[0], 0, 1) eq '$' ? $_[0] : '$' . $_[0];
   }
   my @DWIMs = (
         qr{\A\s* (\S+?) \s* \*  \s*\z}mxs => sub {
            my $target = _prepend_dollar(shift);
            return starts_with($target, '');
         },
         qr{\A\s* (\S+) \s+ eq \s+ (.*?) \s*\z}mxs => sub{
            my $target = _prepend_dollar(shift);
            my $value = shift;
            return $value eq '*' ? starts_with($target, '') : exact($target, $value);
         },
         qr{\A\s* (\S+) \s+ (?: ^ | starts[_-]?with) \s+ (.*?) \s*\z}mxs => sub {
            my $target = _prepend_dollar(shift);
            my $prefix = shift;
            return starts_with($target, $prefix);
         },
         qr{\A\s* (\d+) \s*<=\s* (\S+) \s*<=\s* (\d+) \s*\z}mxs => sub {
            my ($min, $value, $max) = @_;
            s{_}{}g for $min, $max;

            # no "_prepend_dollar" for range conditions
            return range($value, $min, $max);
         },
   );

   sub _resolve_rule {
      my ($string) = @_;

      for my $i (0 .. (@DWIMs - 1) / 2) {
         my ($regex, $callback) = @DWIMs[$i * 2, $i * 2 + 1];
         if (my @captures = $string =~ /$regex/) {
            my $result = $callback->(@captures);
            return $result if defined $result;
         }
      }

      croak "could not understand '$_', bailing out";
   } ## end sub _resolve_rule
}

sub add {
   my ($self, $condition) = @_;
   push @{$self->conditions()},
     ref($condition) ? $condition : _resolve_rule($condition);
   return;
}

sub remove {
   my ($self, $condition) = @_;
   $condition = _resolve_rule($condition) unless ref $condition;
   my $conditions = $self->conditions();
   my @filtered   = grep {
      my $keep;
      if (@$condition != @$_) {    # different lengths => different
         $keep = 1;
      }
      else {
         for my $i (0 .. $#$condition) {
            last if $keep = $condition->[$i] ne $_->[$i];
         }
      }
      $keep;
   } @$conditions;
   $self->conditions(\@filtered);
   return;
} ## end sub remove

sub exact {
   shift if ref $_[0];
   my ($target, $value) = @_;
   return ['eq', $target, $value];
}

sub starts_with {
   shift if ref $_[0];
   my ($target, $value) = @_;
   return ['starts-with', $target, $value];
}

sub range {
   shift if ref $_[0];
   my ($target, $min, $max) = @_;
   return [$target, $min, $max];
}

sub json {
   my ($self, $args) = @_;
   my %params = %$self;
   delete $params{expiration} unless defined $params{expiration};
   return to_json(\%params, $args);
} ## end sub json

sub base64 {
   my $self = shift;
   return encode_base64(Encode::encode('utf-8', $self->json(@_)));
}

{
   no warnings;
   *stringify        = \&json;
   *json_base64      = \&base64;
   *stringify_base64 = \&base64;
}

sub parse {
   my ($self, $json) = @_;

   $json = decode_base64($json)
     unless substr($json, 0, 1) eq '{';

   my %decoded = %{from_json($json)};
   $self->{conditions} = [
      map {
         if   (ref($_) eq 'ARRAY') { $_; }
         else {
            my ($name, $value) = %$_;
            ['eq', '$' . $name, $value];
         }
        } @{$decoded{conditions}}
   ];
   $self->{expiration} = $decoded{expiration};

   return $self;
} ## end sub parse

sub signature {
   my ($self, $key) = @_;
   require Digest::HMAC_SHA1;
   return Digest::HMAC_SHA1::hmac_sha1($self->base64(), $key);
}

sub signature_base64 {
   my ($self, $key) = @_;
   return encode_base64($self->signature($key));
}

# Wrapper around base64 encoder, ensuring that there's no newline
# to make AWS S3 happy
sub encode_base64 {
   return MIME::Base64::encode_base64($_[0], '');
}

1;    # Magic true value required at end of module
__END__