File Coverage

blib/lib/URL/Signature.pm

Criterion	Covered	Total	%
statement	59	62	95.1
branch	8	14	57.1
condition	11	21	52.3
subroutine	13	16	81.2
pod	7	7	100.0
total	98	120	81.6

package URL::Signature;

use warnings;
use strict;

use URI                  ();
use URI::QueryParam      ();
use MIME::Base64    3.11 ();
use Digest::HMAC         ();
use Carp                 ();
use Class::Load          ();
use Params::Util    qw( _STRING _POSINT _NONNEGINT _CLASS );

our $VERSION = '0.03';


sub new {
    my ($class, %attrs) = @_;
    Carp::croak('you must specify a secret key!')
        unless exists $attrs{'key'} and defined _STRING($attrs{'key'});

    # Digest::SHA defaults to SHA-1
    $attrs{'digest'} ||= 'Digest::SHA';
    Carp::croak('digest must be a valid Perl class')
        unless defined _CLASS($attrs{'digest'})
           and Class::Load::load_class($attrs{'digest'});

    $attrs{'length'} ||= 28;
    Carp::croak('length should be a positive integer')
        unless defined _POSINT($attrs{'length'});

    $attrs{'format'} ||= 'path';
    my $child_class = 'URL::Signature::' . ucfirst $attrs{'format'};

    Carp::croak(qq[invalid format '$attrs{format}'])
        unless defined _STRING($attrs{'format'}) and _CLASS($child_class);

    $attrs{'hmac'} = Digest::HMAC->new( $attrs{'key'}, $attrs{'digest'} );

    my ($loaded, $error) = Class::Load::try_load_class( $child_class );
    Carp::croak(qq[error trying to load format class '$child_class': $error])
        unless $loaded;

    my $self = bless \%attrs, $child_class;
    $self->BUILD;
    return $self;
}


sub code_for_uri {
    my ($self, $uri) = @_;

    # ensure query parameters are sorted before encoding.
    my %params = $uri->query_form;
    $uri->query_form( map { $_ => $params{$_} } sort keys %params );

    my $code = MIME::Base64::encode_base64url(
        $self->{hmac}->reset->add( $uri->as_string )->digest
    );

    # truncate the digest, if necessary
    $code = substr $code, 0, $self->{'length'};
    return $code;
}


sub sign {
    my ($self, $path) = @_;
    my $uri = URI->new( $path );
    my $code = $self->code_for_uri( $uri );

    return $self->append( $uri, $code );
}


sub validate {
    my ($self, $path, $old_code) = @_;
    my $uri = URI->new( $path );

    return $old_code eq $self->code_for_uri( $uri )
        if $old_code;

    my ($code, $new_uri) = $self->extract( $uri );
    return if    not $code
              or not $uri
              or $code ne $self->code_for_uri( $new_uri );

    return $new_uri;
}


# let our subclasses implement those
sub BUILD   {}
sub extract {}
sub append  {}


42;
__END__