File Coverage

blib/lib/JSON/WebToken.pm

Criterion	Covered	Total	%
statement	113	114	99.1
branch	43	44	97.7
condition	23	25	92.0
subroutine	22	22	100.0
pod	5	7	71.4
total	206	212	97.1

package JSON::WebToken;

use strict;
use warnings;
use 5.008_001;

our $VERSION = '0.09';

use parent 'Exporter';

use Carp qw(croak);
use JSON qw(encode_json decode_json);
use MIME::Base64 qw(encode_base64 decode_base64);
use Module::Runtime qw(use_module);

use JSON::WebToken::Constants;
use JSON::WebToken::Exception;

our @EXPORT = qw(encode_jwt decode_jwt);

our $ALGORITHM_MAP = {
    # for JWS
    HS256  => 'HMAC',
    HS384  => 'HMAC',
    HS512  => 'HMAC',
    RS256  => 'RSA',
    RS384  => 'RSA',
    RS512  => 'RSA',
#    ES256  => 'EC',
#    ES384  => 'EC',
#    ES512  => 'EC',
    none   => 'NONE',

    # for JWE
    RSA1_5           => 'RSA',
#    'RSA-OAEP'       => 'OAEP',
#    A128KW           => '',
#    A256KW           => '',
    dir              => 'NONE',
#    'ECDH-ES'        => '',
#    'ECDH-ES+A128KW' => '',
#    'ECDH-ES+A256KW' => '',

    # for JWK
#    EC  => 'EC',
    RSA => 'RSA',
};

#our $ENCRIPTION_ALGORITHM_MAP = {
#    'A128CBC+HS256' => 'AES_CBC',
#    'A256CBC+HS512' => 'AES_CBC',
#    A128GCM         => '',
#    A256GCM         => '',
#};

sub encode {
    my ($class, $claims, $secret, $algorithm, $extra_headers) = @_;
    unless (ref $claims eq 'HASH') {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_INVALID_PARAMETER,
            message => 'Usage: JSON::WebToken->encode(\%claims [, $secret, $algorithm, \%$extra_headers ])',
        );
    }

    $algorithm     ||= 'HS256';
    $extra_headers ||= {};

    my $header = {
#        typ parameter is OPTIONAL ("JWT" or "urn:ietf:params:oauth:token-type:jwt")
#        typ => 'JWT',
        alg => $algorithm,
        %$extra_headers,
    };

    $algorithm = $header->{alg};
    if ($algorithm ne 'none' && !defined $secret) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_MISSING_SECRET,
            message => 'secret must be specified',
        );
    }

    my $header_segment  = encode_base64url(encode_json $header);
    my $claims_segment  = encode_base64url(encode_json $claims);
    my $signature_input = join '.', $header_segment, $claims_segment;

    my $signature = $class->_sign($algorithm, $signature_input, $secret);

    return join '.', $signature_input, encode_base64url($signature);
}

sub encode_jwt {
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    __PACKAGE__->encode(@_);
}

sub decode {
    my ($class, $jwt, $secret, $verify_signature, $accept_algorithm_none) = @_;
    unless (defined $jwt) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_INVALID_PARAMETER,
            message => 'Usage: JSON::WebToken->decode($jwt [, $secret, $verify_signature, $accept_algorithm_none ])',
        );
    }

    $verify_signature = 1 unless defined $verify_signature;
    if ($verify_signature && !defined $secret) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_MISSING_SECRET,
            message => 'secret must be specified',
        );
    }

    my $segments = [ split '\.', $jwt ];
    unless (@$segments >= 2 && @$segments <= 4) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_INVALID_SEGMENT_COUNT,
            message => "Not enough or too many segments by $jwt",
        );
    }

    my ($header_segment, $claims_segment, $crypto_segment) = @$segments;
    my $signature_input = join '.', $header_segment, $claims_segment;

    my ($header, $claims, $signature);
    eval {
        $header    = decode_json decode_base64url($header_segment);
        $claims    = decode_json decode_base64url($claims_segment);
        $signature = decode_base64url($crypto_segment) if $header->{alg} ne 'none' && $verify_signature;
    };
    if (my $e = $@) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_INVALID_SEGMENT_ENCODING,
            message => 'Invalid segment encoding',
        );
    }

    return $claims unless $verify_signature;

    # https://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-37#section-3.6
    if ( $header->{alg} eq 'none' && ! $accept_algorithm_none ) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_UNACCEPTABLE_ALGORITHM,
            message => 'Algorithm "none" is not acceptable by default',
        );
    }

    if (ref $secret eq 'CODE') {
        $secret = $secret->($header, $claims);
    }

    my $algorithm = $header->{alg};
    if ($algorithm eq 'none' and $crypto_segment) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_UNWANTED_SIGNATURE,
            message => 'Signature must be the empty string when alg is none',
        );
    }

    unless ($class->_verify($algorithm, $signature_input, $secret, $signature)) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_INVALID_SIGNATURE,
            message => "Invalid signature by $signature",
        );
    }

    return $claims;
}

sub decode_jwt {
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    __PACKAGE__->decode(@_);
}

sub add_signing_algorithm {
    my ($class, $algorithm, $signing_class) = @_;
    unless ($algorithm && $signing_class) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_INVALID_PARAMETER,
            message => 'Usage: JSON::WebToken->add_signing_algorithm($algorithm, $signing_class)',
        );
    }
    $ALGORITHM_MAP->{$algorithm} = $signing_class;
}

sub _sign {
    my ($class, $algorithm, $message, $secret) = @_;
    return '' if $algorithm eq 'none';

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    $class->_ensure_class_loaded($algorithm)->sign($algorithm, $message, $secret);
}

sub _verify {
    my ($class, $algorithm, $message, $secret, $signature) = @_;
    return 1 if $algorithm eq 'none';

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    $class->_ensure_class_loaded($algorithm)->verify($algorithm, $message, $secret, $signature);
}

my (%class_loaded, %alg_to_class);
sub _ensure_class_loaded {
    my ($class, $algorithm) = @_;
    return $alg_to_class{$algorithm} if $alg_to_class{$algorithm};

    my $klass = $ALGORITHM_MAP->{$algorithm};
    unless ($klass) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_NOT_SUPPORTED_SIGNING_ALGORITHM,
            message => "`$algorithm` is Not supported siging algorithm",
        );
    }

    my $signing_class = $klass =~ s/^\+// ? $klass : "JSON::WebToken::Crypt::$klass";
    return $signing_class if $class_loaded{$signing_class};

    use_module $signing_class unless $class->_is_inner_package($signing_class);

    $class_loaded{$signing_class} = 1;
    $alg_to_class{$algorithm}     = $signing_class;

    return $signing_class;
}

sub _is_inner_package {
    my ($class, $klass) = @_;
    no strict 'refs';
    %{ "$klass\::" } ? 1 : 0;
}

####################################################
# Taken from newer MIME::Base64
# In order to support older version of MIME::Base64
####################################################
sub encode_base64url {
    my $e = encode_base64(shift, "");
    $e =~ s/=+\z//;
    $e =~ tr[+/][-_];
    return $e;
}

sub decode_base64url {
    my $s = shift;
    $s =~ tr[-_][+/];
    $s .= '=' while length($s) % 4;
    return decode_base64($s);
}

1;
__END__