SWAMPy

✎ CARVE FLESH

EDITING: WebToken.pm

package JSON::WebToken;

use strict;
use warnings;
use 5.008_001;

our $VERSION = '0.10';

use parent 'Exporter';

use Carp qw(croak carp);
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         => '',
#};

our $DEFAULT_ALLOWED_ALGORITHMS = [ grep { $_ ne "none" } (keys %$ALGORITHM_MAP) ];

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, $accepted_algorithms) = @_;

if (ref $accepted_algorithms eq 'ARRAY') {
        # do nothing
    }
    elsif (defined $accepted_algorithms) {
        if ($accepted_algorithms =~/^[01]$/) {
            carp "accept_algorithm none is deprecated";
            $accepted_algorithms = !!$accepted_algorithms ?
                [@$DEFAULT_ALLOWED_ALGORITHMS, "none"] :  $DEFAULT_ALLOWED_ALGORITHMS;
        }
        else {
            $accepted_algorithms = [ $accepted_algorithms ];
        }
    }
    else {
        $accepted_algorithms = $DEFAULT_ALLOWED_ALGORITHMS;
    }

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

$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;

my $algorithm = $header->{alg};
    # https://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-37#section-3.6
    unless ( grep { $_ eq $algorithm } (@$accepted_algorithms) ) {
        JSON::WebToken::Exception->throw(
            code    => ERROR_JWT_UNACCEPTABLE_ALGORITHM,
            message => "Algorithm \"$algorithm\" is not acceptable. Followings are accepted:" . join(",", @$accepted_algorithms) ,
        );
    }

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

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)',
        );
    }
    push(@$DEFAULT_ALLOWED_ALGORITHMS, $algorithm);
    $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__

=encoding utf-8

=for stopwords

=head1 NAME

JSON::WebToken - JSON Web Token (JWT) implementation

=head1 SYNOPSIS

use Test::More;
  use JSON;
  use JSON::WebToken;

my $claims = {
      iss => 'joe',
      exp => 1300819380,
      'http://example.com/is_root' => JSON::true,
  };
  my $secret = 'secret';

my $jwt = encode_jwt $claims, $secret;
  my $got = decode_jwt $jwt, $secret;
  is_deeply $got, $claims;

done_testing;

=head1 DESCRIPTION

JSON::WebToken is JSON Web Token (JWT) implementation for Perl

B<< THIS MODULE IS ALPHA LEVEL INTERFACE. >>

=head1 METHODS

=head2 encode($claims [, $secret, $algorithm, $extra_headers ]) : String

This method is encoding JWT from hash reference.

my $jwt = JSON::WebToken->encode({
      iss => 'joe',
      exp => 1300819380,
      'http://example.com/is_root' => JSON::true,
  }, 'secret');
  # $jwt = join '.',
  #     'eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9',
  #     'eyJleHAiOjEzMDA4MTkzODAsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJqb2UifQ'
  #     '4ldFxjibgJGz_uaIRCIq89b5ipR-sbI2Uq7B2WNEDs0'

Default encryption algorithm is C<< HS256 >>. You can change algorithm as following:

my $pricate_key_string = '...';
  my $public_key_string  = '...';

my $jwt = JSON::WebToken->encode({
      iss => 'joe',
      exp => 1300819380,
      'http://example.com/is_root' => JSON::true,
  }, $pricate_key_string, 'RS256');

my $claims = JSON::WebToken->decode($jwt, $public_key_string);

When you use RS256, RS384 or RS512 algorithm then, We need L<< Crypt::OpenSSL::RSA >>.

If you want to create a C<< Plaintext JWT >>, should be specify C<< none >> for the algorithm.

my $jwt = JSON::WebToken->encode({
      iss => 'joe',
      exp => 1300819380,
      'http://example.com/is_root' => JSON::true,
  }, '', 'none');
  # $jwt = join '.',
  #     'eyJhbGciOiJub25lIiwidHlwIjoiSldUIn0',
  #     'eyJleHAiOjEzMDA4MTkzODAsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJqb2UifQ',
  #     ''

=head2 decode($jwt [, $secret, $verify_signature, $accepted_algorithms ]) : HASH

This method is decoding hash reference from JWT string.

my $claims = JSON::WebToken->decode($jwt, $secret, 1, ["RS256"]);

Any signing algorithm (except "none") is acceptable by default,
so you should check it with $accepted_algorithms parameter.

=head2 add_signing_algorithm($algorithm, $class)

This method is adding signing algorithm.

# resolve JSON::WebToken::Crypt::MYALG
  JSON::WebToken->add_signing_algorithm('MYALGXXX'   => 'MYALG');

# resolve Some::Class::Algorithm
  JSON::WebToken->add_signing_algorithm('SOMEALGXXX' => '+Some::Class::Algorithm');

SEE ALSO L<< JSON::WebToken::Crypt::HMAC >> or L<< JSON::WebToken::Crypt::RAS >>.

=head1 FUNCTIONS

=head2 encode_jwt($claims [, $secret, $algorithm, $extra_headers ]) : String

Same as C<< encode() >> method.

=head2 decode_jwt($jwt [, $secret, $verify_signature, $accepted_algorithms ]) : Hash

Same as C<< decode() >> method.

=head1 ERROR CODES

JSON::WebToken::Exception will be thrown with following code.

=head2 ERROR_JWT_INVALID_PARAMETER

When some method arguments are not valid.

=head2 ERROR_JWT_MISSING_SECRET

When secret is required. (C<< alg != "none" >>)

=head2 ERROR_JWT_INVALID_SEGMENT_COUNT

When JWT segment count is not between 2 and 4.

=head2 ERROR_JWT_INVALID_SEGMENT_ENCODING

When each JWT segment is not encoded by base64url.

=head2 ERROR_JWT_UNWANTED_SIGNATURE

When C<< alg == "none" >> but signature segment found.

=head2 ERROR_JWT_INVALID_SIGNATURE

When JWT signature is invalid.

=head2 ERROR_JWT_NOT_SUPPORTED_SIGNING_ALGORITHM

When given signing algorithm is not supported.

=head2 ERROR_JWT_UNACCEPTABLE_ALGORITHM

When given signing algorithm is not included in acceptable_algorithms.

=head1 AUTHOR

xaicron E<lt>xaicron@cpan.orgE<gt>

zentooo

=head1 COPYRIGHT

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<< http://tools.ietf.org/html/draft-ietf-oauth-json-web-token >>

=cut

CANCEL

Name	Type	Size	Modified	Actions
↩ ..	DIR	—	—
📁 backportPP/	DIR	—	2026-06-30 22:31
📁 PP/	DIR	—	2025-02-14 06:47
📁 WebToken/	DIR	—	2026-06-24 13:58
📄 PP.pm	PM	87.6 KB	2017-12-21 11:10	EDIT
📄 WebToken.pm	PM	11.8 KB	2021-02-08 17:42	EDIT