lib/Net/Amazon/S3/Policy.pm

   1 package Net::Amazon::S3::Policy;
   2
   3 use version; our $VERSION = qv('0.1.0');
   4
   5 use warnings;
   6 use strict;
   7 use Carp;
   8 use English qw( -no_match_vars );
   9 use JSON;
  10
  11 use Exporter qw( import );
  12 our @EXPORT_OK = qw( exact starts_with range );
  13 our %EXPORT_TAGS = (
  14    all => \@EXPORT_OK,
  15 );
  16
  17 # Module implementation here
  18 sub new {
  19    my $class = shift;
  20    my %args = ref($_[0]) ? %{$_[0]} : @_;
  21    my $self = bless {}, $class;
  22
  23    if ($args{json}) {
  24       $self->parse($args{json});
  25    }
  26    else {
  27       $self->expiration($args{expiration}) if defined $args{expiration};
  28       $self->conditions([]);
  29       $self->add($_) for @{$args{conditions} || []};
  30    }
  31
  32    return $self;
  33 } ## end sub new
  34
  35 # Accessors
  36 sub expiration {
  37    my $self = shift;
  38    my $previous = $self->{expiration};
  39    if (@_) {
  40       my $time = shift;
  41       if ($time  && $time =~ /\A \d+ \z/mxs) {
  42          my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
  43             gmtime($time);
  44          $time = sprintf "%04d-%02d-%02dT%02d:%02d:%02d.000Z", $year + 1900,
  45             $mon + 1, $mday, $hour, $min, $sec;
  46       }
  47       $time ? ($self->{expiration} = $time) : delete $self->{expiration};
  48    }
  49    return $previous;
  50 }
  51
  52 sub conditions {
  53    my $self = shift;
  54    my $previous = $self->{conditions};
  55
  56    if (@_) {
  57       $self->{conditions} = (scalar(@_) == 1) ? shift : [ @_ ];
  58    }
  59
  60    return $previous;
  61 }
  62
  63 { # try to understand rules
  64    my @DWIMs = (
  65       sub {
  66          return unless m{\A\s* (\S+?) \s* \*  \s*\z}mxs;
  67          return starts_with($1, '');
  68       },
  69       sub {
  70          return unless m{\A\s* (\S+) \s+ eq \s+ (.*?) \s*\z}mxs;
  71          return ($2 eq '*') ? starts_with($1, '') : exact($1, $2);
  72       },
  73       sub {
  74          return
  75          unless
  76             m{\A\s* (\S+) \s+ (?: ^ | starts[_-]?with) \s+ (.*?) \s*\z}mxs;
  77          return starts_with($1, $2);
  78       },
  79       sub {
  80          return unless m{\A\s* (\d+) \s*<=\s* (\S+) \s*<=\s* (\d+) \s*\z}mxs;
  81          my ($min, $value, $max) = ($1, $2, $3);
  82          s{_}{}g for $min, $max;
  83          return range($value, $min, $max);
  84       },
  85    );
  86
  87    sub _resolve_rule {
  88       local $_ = shift;
  89       for my $tester (@DWIMs) {
  90          if (my $retval = $tester->()) {
  91             return $retval;
  92          }
  93       }
  94       croak "could not understand '$_', bailing out";
  95    } ## end sub _resolve_rule
  96 }
  97
  98 sub add {
  99    my ($self, $condition) = @_;
 100    push @{$self->conditions()}, ref($condition) ? $condition : _resolve_rule($condition);
 101 } ## end sub add
 102
 103 sub remove {
 104    my ($self, $condition) = @_;
 105    $condition = _resolve_rule($condition) unless ref $condition;
 106    my $conditions = $self->conditions();
 107    my @filtered = grep {
 108       my $keep;
 109       if (@$condition != @$_) {    # different lengths => different
 110          $keep = 1;
 111       }
 112       else {
 113          for my $i (0 .. $#$condition) {
 114             last if $keep = $condition->[$i] ne $_->[$i];
 115          }
 116       }
 117       $keep;
 118    } @$conditions;
 119    $self->conditions(\@filtered);
 120    return;
 121 } ## end sub remove
 122
 123 sub exact {
 124    shift if ref $_[0];
 125    my ($target, $value) = @_;
 126    return ['eq', $target, $value];
 127 }
 128
 129 sub starts_with {
 130    shift if ref $_[0];
 131    my ($target, $value) = @_;
 132    return ['starts-with', $target, $value];
 133 }
 134
 135 sub range {
 136    shift if ref $_[0];
 137    my ($target, $min, $max) = @_;
 138    return [$target, $min, $max];
 139 }
 140
 141 sub json {
 142    my $self = shift;
 143    my %params = %$self;
 144    delete $params{expiration} unless defined $params{expiration};
 145    return to_json(\%params);
 146 }
 147
 148 sub base64 { return _encode_base64($_[0]->json()); }
 149
 150 {
 151    no warnings;
 152    *stringify = \&json;
 153    *json_base64 = \&base64;
 154    *stringify_base64 = \&base64;
 155 }
 156
 157 sub parse {
 158    my ($self, $json) = @_;
 159
 160    $json = _decode_base64($json)
 161       unless substr($json, 0, 1) eq '{';
 162
 163    my %decoded = %{ from_json($json) };
 164    $self->{conditions} = [ map {
 165       if (ref($_) eq 'ARRAY') {$_}
 166       else { [ 'eq', %$_ ] }
 167    } @{$decoded{conditions}} ];
 168    $self->{expiration} = $decoded{expiration};
 169
 170    return $self;
 171 }
 172
 173 sub signature {
 174    my ($self, $key) = @_;
 175    require Digest::HMAC_SHA1;
 176    return hmac_sha1($self->base64(), $key);
 177 }
 178
 179 sub signature_base64 {
 180    my ($self, $key) = @_;
 181    return _encode_base64($self->signature($key));
 182 }
 183
 184 sub _decode_base64 {
 185    require MIME::Base64;
 186    no warnings 'redefine';
 187    *_decode_base64 = \&MIME::Base64::decode_base64;
 188    goto \&MIME::Base64::decode_base64;
 189 }
 190
 191 # Wrapper around base64 encoder, ensuring that there's no newline
 192 # to make AWS S3 happy
 193 sub _encode_base64 {
 194    require MIME::Base64;
 195    (my $retval = MIME::Base64::encode_base64($_[0])) =~ s/\n//gmxs;
 196    return $retval;
 197 }
 198
 199
 200 1;    # Magic true value required at end of module
 201 __END__
 202
 203 =head1 NAME
 204
 205 Net::Amazon::S3::Policy - manage Amazon S3 policies for HTTP POST forms
 206
 207 =head1 VERSION
 208
 209 This document describes Net::Amazon::S3::Policy version 0.1.0. Most likely, this
 210 version number here is outdate, and you should peek the source.
 211
 212
 213 =head1 SYNOPSIS
 214
 215    use Net::Amazon::S3::Policy;
 216
 217    # Expire in one hour
 218    my $policy = Net::Amazon::S3::Policy->new(expiration => time() + 3600);
 219
 220    # Do What I Mean handling of conditions
 221    # Note: single quotes, $key is not a Perl variable in this example!
 222    $policy->add('$key eq path/to/somewhere');
 223    $policy->add('x-some-field starts-with some-prefix');
 224    $policy->add(' 0 <= content-length-range <= 1_000_000 ');
 225    $policy->add('whatever *'); # any value admitted for field 'whatever'
 226
 227    # NON-DWIM interface for conditions
 228    use Net::Amazon::S3::Policy qw( :all ); # OR
 229    use Net::Amazon::S3::Policy qw( exact starts_with range );
 230    $policy->add(exact('field', 'whatever spaced value   ');
 231    $policy->add(starts_with('other-field', '   yadda    ');
 232    $policy->add(range('percentual', 0, 100));
 233
 234    # The output as JSON
 235    print $policy->stringify(), "\n"; # OR
 236    print $policy->json(), "\n";
 237
 238    # Where the stuff is really needed: HTML FORMs for HTTP POSTs
 239    my $policy_for_form    = $policy->base64();
 240    my $signature_for_form = $policy->signature_base64($key);
 241
 242    # If you ever receive a policy...
 243    my $received = Net::Amazon::S3::Policy->new(json => $json_text);
 244    my $rec2 = Net::Amazon::S3::Policy->new();
 245    $rec2->parse($json_base64); # either JSON or its Base64 encoding
 246
 247
 248 =head1 DESCRIPTION
 249
 250 Net::Amazon::S3::Policy gives you an object-oriented interface to
 251 manage policies for Amazon S3 HTTP POST uploads.
 252
 253 Amazon S3 relies upon either a REST interface (see L<Net::Amazon::S3>)
 254 or a SOAP one; as an added service, it is possible to give access to
 255 the upload of resources using HTTP POSTs that do not involve using
 256 any of these two interfaces, but a single HTML FORM. The rules you
 257 have to follow are explained in the Amazon S3 Developer Guide.
 258
 259 More or less, it boils down to the following:
 260
 261 =over
 262
 263 =item *
 264
 265 if the target bucket is not writeable by the anonymous group, you'll need
 266 to set an access policy;
 267
 268 =item *
 269
 270 almost every field in the HTML FORM that will be used to build up the HTTP POST
 271 message by the browser needs to be included into a I<policy>, and the policy
 272 has to be sent along within the HTTP POST
 273
 274 =item *
 275
 276 together with the I<policy>, also the bucket owner's AWS ID (the public one) has to
 277 be sent, together with a digital signature of the policy that has to be created
 278 using the bucket owner's AWS secret key.
 279
 280 =back
 281
 282 So, you'll have to add three fields to the HTTP POST in order for it to comply
 283 with Amazon's requirement when the bucket is not publicly writeable:
 284
 285 =over
 286
 287 =item C<AWSAccessKeyId>
 288
 289 given "as-is", i.e. as you copied from your account in Amazon Web Services;
 290
 291 =item C<policy>
 292
 293 given as a JSON document that is Base64 encoded;
 294
 295 =item C<signature>
 296
 297 calculated as a SHA1-HMAC of the Base64-encoded policy, using your secret
 298 key as the signature key, and then encoded with Base64.
 299
 300 =back
 301
 302 This module lets you manage the build-up of a policy document, providing you
 303 with tools to get the Base64 encoding of the resulting JSON policy document,
 304 and to calculate the Base64 encoding of the signature. See L</Example> for
 305 a complete example of how to do this.
 306
 307 In addition to I<policy synthesis>, the module is also capable of parsing
 308 some policy (base64-encoded or not, but in JSON format). This shouldn't
 309 be a need in general... possibly for debug reasons.
 310
 311 =head2 Example
 312
 313 For example, suppose that you have the following HTML FORM to allow selected
 314 uploads to the C<somebucket> bucket (see the Amazon S3 Developer Guide for
 315 details about writing the HTML FORM):
 316
 317    <form action="http://somebucket.s3.amazonaws.com/" method="post"
 318          enctype="multipart/form-data">
 319       <!-- inputs needed because bucket is not publicly writeable -->
 320       <input type="hidden" name="AWSAccessKeyId" value="your-ID-here">
 321       <input type="hidden" name="policy" value="base64-encoded-policy">
 322       <input type="hidden" name="signature" value="base64-encoded-signature">
 323
 324       <!-- input needed by AWS-S3 logic: there MUST be a key -->
 325       <input type="hidden" name="key" value="/restricted/${filename}">
 326
 327       <!-- inputs that you want to include in your form -->
 328       <input type="hidden" name="Content-Type" value="image/jpeg">
 329       <label for="colour">Colour</label>
 330       <input type="text" id="colour" name="x-amz-meta-colour" value="green">
 331
 332       <!-- input needed to have something to upload. LAST IN FORM! -->
 333       <input type="file" id="file" name="file">
 334    </form>
 335
 336 You need to include the following elements in your policy:
 337
 338 =over
 339
 340 =item *
 341
 342 C<key>
 343
 344 =item *
 345
 346 C<Content-Type>
 347
 348 =item *
 349
 350 C<x-amz-meta-colour>
 351
 352 =back
 353
 354 Your policy can then be built like this:
 355
 356    my $policy = Net::Amazon::S3::Policy->new(
 357       expiration => time() + 60 * 60, # one-hour policy
 358       conditions => [
 359          '$key         starts-with /restricted/', # restrict to here
 360          'Content-Type starts-with image/', # accept any image format
 361          'x-amz-meta-colour *', # accept any colour
 362       ],
 363    );
 364
 365    # Put this as the value for "policy",
 366    # instead of "base64-encoded-policy"
 367    my $policy_for_form = $policy->base64();
 368
 369    # Put this as the value for "signature",
 370    # instead of "base64-encoded-signature"
 371    my $signature_for_form = $policy->signature_base64();
 372
 373 =head1 INTERFACE
 374
 375 =head2 Module Interface
 376
 377 =over
 378
 379 =item B<< new (%args)  >>
 380
 381 =item B<< new (\%args)  >>
 382
 383 constructor to create a new Net::Amazon::S3::Policy object.
 384
 385 Arguments can be passed either as a single hash reference, or
 386 as a hash. Choose whatever you like most.
 387
 388 Recognised keys are:
 389
 390 =over
 391
 392 =item expiration
 393
 394 the expiration date for this policy.
 395
 396 =item conditions
 397
 398 a list of conditions to initialise the object. This should
 399 point to an array with the conditions, that will be passed through
 400 the L</add> method.
 401
 402 =item json
 403
 404 a piece of JSON text to parse the configuration from. The presence
 405 of this parameter overrides the other two.
 406
 407 =back
 408
 409 =item B<< expiration ()  >>
 410
 411 =item B<< expiration ($time)  >>
 412
 413 get/set the expiration time for the condition. Set to a false value
 414 to remove the expiration time from the policy.
 415
 416 You should either pass an ISO8601 datetime string, or an epoch value.
 417 You'll always get an ISO8601 string back.
 418
 419 =item B<< conditions () >>
 420
 421 =item B<< conditions (@conditions)  >>
 422
 423 =item B<< conditions (\@conditions)  >>
 424
 425 get/set the conditions in the policy. You should never need to use this
 426 method, because the L</add> and L</remove> are there for you to interact
 427 with this member. If you want to use this, anyway, be sure to take
 428 a look to the functions in L</Convenience Condition Functions>.
 429
 430 =item B<< add ($spec)  >>
 431
 432 add a specification to the list of conditions.
 433
 434 A specification can be either an ARRAY reference, or a textual one:
 435
 436 =over
 437
 438 =item *
 439
 440 if you pass an ARRAY reference, it should be something like the one
 441 returned by any of the functions in L</Convenience Condition Functions>;
 442
 443 =item *
 444
 445 othewise, it can be a string with a single condition, like the following
 446 examples:
 447
 448    some-field eq some-value
 449    some-other-field starts-with /path/to/somewhere/
 450    10 <= numeric-value <= 1000
 451
 452 Note that the string specification is less "strict" in checking its
 453 parameters; in particular, you should stick to the ARRAY reference if
 454 your parameters have a space inside. You can use the following formats:
 455
 456 =over
 457
 458 =item C<< <name> eq <value> >>
 459
 460 set a name to have a given value, exactly;
 461
 462 =item C<< <name> starts-with <prefix> >>
 463
 464 =item C<< <name> starts_with <prefix> >>
 465
 466 =item C<< <name> ^ <prefix> >>
 467
 468 set the prefix that has to be matched against the value
 469 for the field with the given name. If the prefix is left
 470 empty, every possible value will be admitted;
 471
 472 =item C<< <name> * >>
 473
 474 admit any value for the given field, just like setting an empty
 475 value for a C<starts-with> rule;
 476
 477 =item C<< <min> <= <name> <= <max> >>
 478
 479 set an allowable range for the given field.
 480
 481 =back
 482
 483 =back
 484
 485 =item B<< remove ($spec)  >>
 486
 487 remove a condition in the list of conditions. The parameter is
 488 regarded exactly as in L</add>; once it is found, the list of
 489 conditions will be filtered to exclude that particular
 490 condition, exactly.
 491
 492 =item B<< json () >>
 493
 494 =item B<< stringify () >>
 495
 496 get a textual version of the object, in JSON format. This is the
 497 base format used to interact with Amazon S3.
 498
 499 =item B<< base64 () >>
 500
 501 =item B<< json_base64 () >>
 502
 503 =item B<< stringify_base64 () >>
 504
 505 get a textual version of the object, as a Base64 encoding of the
 506 JSON representation (see L</json>). This is what should to be put
 507 as C<policy> field in the POST form.
 508
 509
 510 =item B<< parse ($json_text)  >>
 511
 512 parse a JSON representation of a policy and fill in the object. This
 513 is the opposite of L</json>.
 514
 515
 516 =item B<< signature ($key)  >>
 517
 518 get the signature for the Base 64 encoding of the JSON representation of
 519 the policy. The signature is the SHA1-HMAC digital signature, with the
 520 given key.
 521
 522
 523 =item B<< signature_base64 ($key)  >>
 524
 525 get the Base64 encoding of the signature, as given by L</signature>. This
 526 is the value that should be put in the C<signature> field in the POST
 527 form.
 528
 529 =back
 530
 531 =head2 Convenience Condition Functions
 532
 533 The following functions can be optionally imported from the
 534 module, and can be used indifferently as class/instance
 535 methods or as functions.
 536
 537 =over
 538
 539 =item B<< exact ($target, $value)  >>
 540
 541 produce an I<exact value> condition. This condition is an array
 542 reference with the following elements:
 543
 544 =over
 545
 546 =item *
 547
 548 the C<eq> string;
 549
 550 =item *
 551
 552 the I<name> of the field;
 553
 554 =item *
 555
 556 the I<value> that the field should match exactly.
 557
 558 =back
 559
 560 =item B<< starts_with ($target, $value)  >>
 561
 562 produce a I<starts-with> condition. This condition is an array
 563 reference with the following elements:
 564
 565 =over
 566
 567 =item *
 568
 569 the C<starts-with> string;
 570
 571 =item *
 572
 573 the I<name> of the field;
 574
 575 =item *
 576
 577 the I<prefix> that has to be matched by the field's value
 578
 579 =back
 580
 581 =item B<< range ($target, $min, $max) >>
 582
 583 produce a I<value range> condition. This condition is an array
 584 reference with the following elements:
 585
 586 =over
 587
 588 =item *
 589
 590 the I<name> of the field;
 591
 592 =item *
 593
 594 the I<minimum> value allowed for the field's value;
 595
 596 =item *
 597
 598 the I<maximum> value allowed for the field's value;
 599
 600 =back
 601
 602 =back
 603
 604 =head1 DIAGNOSTICS
 605
 606
 607 =over
 608
 609 =item C<< could not understand '%s', bailing out >>
 610
 611 The L</add> and L</remove> function try their best to understand
 612 a condition when given in string form... but you should really
 613 stick to the format given in the documentation!
 614
 615 =back
 616
 617
 618 =head1 CONFIGURATION AND ENVIRONMENT
 619
 620 Net::Amazon::S3::Policy requires no configuration files or environment variables.
 621
 622
 623 =head1 DEPENDENCIES
 624
 625 The C<version> pragma (which has been included in Perl 5.10) and the
 626 L</JSON> module.
 627
 628
 629 =head1 INCOMPATIBILITIES
 630
 631 None reported.
 632
 633
 634 =head1 BUGS AND LIMITATIONS
 635
 636 No bugs have been reported.
 637
 638 Please report any bugs or feature requests through http://rt.cpan.org/
 639
 640
 641 =head1 AUTHOR
 642
 643 Flavio Poletti  C<< <flavio [at] polettix [dot] it> >>
 644
 645
 646 =head1 LICENCE AND COPYRIGHT
 647
 648 Copyright (c) 2008, Flavio Poletti C<< <flavio [at] polettix [dot] it> >>. All rights reserved.
 649
 650 This module is free software; you can redistribute it and/or
 651 modify it under the same terms as Perl 5.8.x itself. See L<perlartistic>
 652 and L<perlgpl>.
 653
 654 Questo modulo è software libero: potete ridistribuirlo e/o
 655 modificarlo negli stessi termini di Perl 5.8.x stesso. Vedete anche
 656 L<perlartistic> e L<perlgpl>.
 657
 658
 659 =head1 DISCLAIMER OF WARRANTY
 660
 661 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 662 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 663 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 664 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 665 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 666 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 667 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 668 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 669 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 670
 671 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 672 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 673 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 674 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 675 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 676 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 677 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 678 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 679 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 680 SUCH DAMAGES.
 681
 682 =head1 NEGAZIONE DELLA GARANZIA
 683
 684 Poiché questo software viene dato con una licenza gratuita, non
 685 c'è alcuna garanzia associata ad esso, ai fini e per quanto permesso
 686 dalle leggi applicabili. A meno di quanto possa essere specificato
 687 altrove, il proprietario e detentore del copyright fornisce questo
 688 software "così com'è" senza garanzia di alcun tipo, sia essa espressa
 689 o implicita, includendo fra l'altro (senza però limitarsi a questo)
 690 eventuali garanzie implicite di commerciabilità e adeguatezza per
 691 uno scopo particolare. L'intero rischio riguardo alla qualità ed
 692 alle prestazioni di questo software rimane a voi. Se il software
 693 dovesse dimostrarsi difettoso, vi assumete tutte le responsabilità
 694 ed i costi per tutti i necessari servizi, riparazioni o correzioni.
 695
 696 In nessun caso, a meno che ciò non sia richiesto dalle leggi vigenti
 697 o sia regolato da un accordo scritto, alcuno dei detentori del diritto
 698 di copyright, o qualunque altra parte che possa modificare, o redistribuire
 699 questo software così come consentito dalla licenza di cui sopra, potrà
 700 essere considerato responsabile nei vostri confronti per danni, ivi
 701 inclusi danni generali, speciali, incidentali o conseguenziali, derivanti
 702 dall'utilizzo o dall'incapacità di utilizzo di questo software. Ciò
 703 include, a puro titolo di esempio e senza limitarsi ad essi, la perdita
 704 di dati, l'alterazione involontaria o indesiderata di dati, le perdite
 705 sostenute da voi o da terze parti o un fallimento del software ad
 706 operare con un qualsivoglia altro software. Tale negazione di garanzia
 707 rimane in essere anche se i dententori del copyright, o qualsiasi altra
 708 parte, è stata avvisata della possibilità di tali danneggiamenti.
 709
 710 Se decidete di utilizzare questo software, lo fate a vostro rischio
 711 e pericolo. Se pensate che i termini di questa negazione di garanzia
 712 non si confacciano alle vostre esigenze, o al vostro modo di
 713 considerare un software, o ancora al modo in cui avete sempre trattato
 714 software di terze parti, non usatelo. Se lo usate, accettate espressamente
 715 questa negazione di garanzia e la piena responsabilità per qualsiasi
 716 tipo di danno, di qualsiasi natura, possa derivarne.
 717
 718 =cut