File Coverage

blib/lib/JSON/WebToken.pm
Criterion Covered Total %
statement 121 122 99.1
branch 51 52 98.0
condition 20 22 90.9
subroutine 22 22 100.0
pod 5 7 71.4
total 219 225 97.3


line stmt bran cond sub pod time code
1             package JSON::WebToken;
2              
3 8     8   177114 use strict;
  8         14  
  8         277  
4 8     8   35 use warnings;
  8         15  
  8         200  
5 8     8   150 use 5.008_001;
  8         26  
  8         365  
6              
7             our $VERSION = '0.10';
8              
9 8     8   23628 use parent 'Exporter';
  8         2136  
  8         37  
10              
11 8     8   408 use Carp qw(croak carp);
  8         12  
  8         567  
12 8     8   4777 use JSON qw(encode_json decode_json);
  8         82813  
  8         39  
13 8     8   5397 use MIME::Base64 qw(encode_base64 decode_base64);
  8         4544  
  8         642  
14 8     8   3316 use Module::Runtime qw(use_module);
  8         8468  
  8         47  
15              
16 8     8   3204 use JSON::WebToken::Constants;
  8         17  
  8         581  
17 8     8   2644 use JSON::WebToken::Exception;
  8         16  
  8         9216  
18              
19             our @EXPORT = qw(encode_jwt decode_jwt);
20              
21             our $ALGORITHM_MAP = {
22             # for JWS
23             HS256 => 'HMAC',
24             HS384 => 'HMAC',
25             HS512 => 'HMAC',
26             RS256 => 'RSA',
27             RS384 => 'RSA',
28             RS512 => 'RSA',
29             # ES256 => 'EC',
30             # ES384 => 'EC',
31             # ES512 => 'EC',
32             none => 'NONE',
33              
34             # for JWE
35             RSA1_5 => 'RSA',
36             # 'RSA-OAEP' => 'OAEP',
37             # A128KW => '',
38             # A256KW => '',
39             dir => 'NONE',
40             # 'ECDH-ES' => '',
41             # 'ECDH-ES+A128KW' => '',
42             # 'ECDH-ES+A256KW' => '',
43              
44             # for JWK
45             # EC => 'EC',
46             RSA => 'RSA',
47             };
48              
49             #our $ENCRIPTION_ALGORITHM_MAP = {
50             # 'A128CBC+HS256' => 'AES_CBC',
51             # 'A256CBC+HS512' => 'AES_CBC',
52             # A128GCM => '',
53             # A256GCM => '',
54             #};
55              
56             our $DEFAULT_ALLOWED_ALGORITHMS = [ grep { $_ ne "none" } (keys %$ALGORITHM_MAP) ];
57              
58             sub encode {
59 22     22 1 505 my ($class, $claims, $secret, $algorithm, $extra_headers) = @_;
60 22 100       80 unless (ref $claims eq 'HASH') {
61 2         9 JSON::WebToken::Exception->throw(
62             code => ERROR_JWT_INVALID_PARAMETER,
63             message => 'Usage: JSON::WebToken->encode(\%claims [, $secret, $algorithm, \%$extra_headers ])',
64             );
65             }
66              
67 20   100     73 $algorithm ||= 'HS256';
68 20   100     93 $extra_headers ||= {};
69              
70 20         61 my $header = {
71             # typ parameter is OPTIONAL ("JWT" or "urn:ietf:params:oauth:token-type:jwt")
72             # typ => 'JWT',
73             alg => $algorithm,
74             %$extra_headers,
75             };
76              
77 20         40 $algorithm = $header->{alg};
78 20 100 100     89 if ($algorithm ne 'none' && !defined $secret) {
79 1         4 JSON::WebToken::Exception->throw(
80             code => ERROR_JWT_MISSING_SECRET,
81             message => 'secret must be specified',
82             );
83             }
84              
85 19         153 my $header_segment = encode_base64url(encode_json $header);
86 19         78 my $claims_segment = encode_base64url(encode_json $claims);
87 19         53 my $signature_input = join '.', $header_segment, $claims_segment;
88              
89 19         62 my $signature = $class->_sign($algorithm, $signature_input, $secret);
90              
91 18         63 return join '.', $signature_input, encode_base64url($signature);
92             }
93              
94             sub encode_jwt {
95 20     20 1 26643 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
96 20         97 __PACKAGE__->encode(@_);
97             }
98              
99             sub decode {
100 25     25 1 1081 my ($class, $jwt, $secret, $verify_signature, $accepted_algorithms) = @_;
101              
102 25 100       87 if (ref $accepted_algorithms eq 'ARRAY') {
    100          
103             # do nothing
104             }
105             elsif (defined $accepted_algorithms) {
106 5 100       24 if ($accepted_algorithms =~/^[01]$/) {
107 3         930 carp "accept_algorithm none is deprecated";
108 3 100       31 $accepted_algorithms = !!$accepted_algorithms ?
109             [@$DEFAULT_ALLOWED_ALGORITHMS, "none"] : $DEFAULT_ALLOWED_ALGORITHMS;
110             }
111             else {
112 2         37 $accepted_algorithms = [ $accepted_algorithms ];
113             }
114             }
115             else {
116 18         24 $accepted_algorithms = $DEFAULT_ALLOWED_ALGORITHMS;
117             }
118              
119 25 100       61 unless (defined $jwt) {
120 1         5 JSON::WebToken::Exception->throw(
121             code => ERROR_JWT_INVALID_PARAMETER,
122             message => 'Usage: JSON::WebToken->decode($jwt [, $secret, $verify_signature, $accepted_algorithms ])',
123             );
124             }
125              
126 24 100       52 $verify_signature = 1 unless defined $verify_signature;
127 24 100 100     116 if ($verify_signature && !defined $secret) {
128 1         4 JSON::WebToken::Exception->throw(
129             code => ERROR_JWT_MISSING_SECRET,
130             message => 'secret must be specified',
131             );
132             }
133              
134 23         91 my $segments = [ split '\.', $jwt ];
135 23 100 100     123 unless (@$segments >= 2 && @$segments <= 4) {
136 2         10 JSON::WebToken::Exception->throw(
137             code => ERROR_JWT_INVALID_SEGMENT_COUNT,
138             message => "Not enough or too many segments by $jwt",
139             );
140             }
141              
142 21         40 my ($header_segment, $claims_segment, $crypto_segment) = @$segments;
143 21         44 my $signature_input = join '.', $header_segment, $claims_segment;
144              
145 21         25 my ($header, $claims, $signature);
146 21         27 eval {
147 21         50 $header = decode_json decode_base64url($header_segment);
148 20         42 $claims = decode_json decode_base64url($claims_segment);
149 20 100 100     113 $signature = decode_base64url($crypto_segment) if $header->{alg} ne 'none' && $verify_signature;
150             };
151 21 100       49 if (my $e = $@) {
152 1         4 JSON::WebToken::Exception->throw(
153             code => ERROR_JWT_INVALID_SEGMENT_ENCODING,
154             message => 'Invalid segment encoding',
155             );
156             }
157              
158 20 100       44 return $claims unless $verify_signature;
159              
160 19         25 my $algorithm = $header->{alg};
161             # https://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-37#section-3.6
162 19 100       34 unless ( grep { $_ eq $algorithm } (@$accepted_algorithms) ) {
  144         203  
163 3         21 JSON::WebToken::Exception->throw(
164             code => ERROR_JWT_UNACCEPTABLE_ALGORITHM,
165             message => "Algorithm \"$algorithm\" is not acceptable. Followings are accepted:" . join(",", @$accepted_algorithms) ,
166             );
167             }
168              
169 16 100       44 if (ref $secret eq 'CODE') {
170 2         4 $secret = $secret->($header, $claims);
171             }
172              
173 16 100 100     92 if ($algorithm eq 'none' and $crypto_segment) {
174 1         5 JSON::WebToken::Exception->throw(
175             code => ERROR_JWT_UNWANTED_SIGNATURE,
176             message => 'Signature must be the empty string when alg is none',
177             );
178             }
179              
180 15 100       49 unless ($class->_verify($algorithm, $signature_input, $secret, $signature)) {
181 1         9 JSON::WebToken::Exception->throw(
182             code => ERROR_JWT_INVALID_SIGNATURE,
183             message => "Invalid signature by $signature",
184             );
185             }
186              
187 14         87 return $claims;
188             }
189              
190             sub decode_jwt {
191 23     23 1 6412 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
192 23         75 __PACKAGE__->decode(@_);
193             }
194              
195             sub add_signing_algorithm {
196 2     2 1 1332 my ($class, $algorithm, $signing_class) = @_;
197 2 50 33     10 unless ($algorithm && $signing_class) {
198 0         0 JSON::WebToken::Exception->throw(
199             code => ERROR_JWT_INVALID_PARAMETER,
200             message => 'Usage: JSON::WebToken->add_signing_algorithm($algorithm, $signing_class)',
201             );
202             }
203 2         5 push(@$DEFAULT_ALLOWED_ALGORITHMS, $algorithm);
204 2         6 $ALGORITHM_MAP->{$algorithm} = $signing_class;
205             }
206              
207             sub _sign {
208 19     19   32 my ($class, $algorithm, $message, $secret) = @_;
209 19 100       54 return '' if $algorithm eq 'none';
210              
211 15         23 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
212 15         40 $class->_ensure_class_loaded($algorithm)->sign($algorithm, $message, $secret);
213             }
214              
215             sub _verify {
216 15     15   33 my ($class, $algorithm, $message, $secret, $signature) = @_;
217 15 100       44 return 1 if $algorithm eq 'none';
218              
219 13         22 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
220 13         23 $class->_ensure_class_loaded($algorithm)->verify($algorithm, $message, $secret, $signature);
221             }
222              
223             my (%class_loaded, %alg_to_class);
224             sub _ensure_class_loaded {
225 28     28   37 my ($class, $algorithm) = @_;
226 28 100       130 return $alg_to_class{$algorithm} if $alg_to_class{$algorithm};
227              
228 11         23 my $klass = $ALGORITHM_MAP->{$algorithm};
229 11 100       34 unless ($klass) {
230 1         6 JSON::WebToken::Exception->throw(
231             code => ERROR_JWT_NOT_SUPPORTED_SIGNING_ALGORITHM,
232             message => "`$algorithm` is Not supported siging algorithm",
233             );
234             }
235              
236 10 100       41 my $signing_class = $klass =~ s/^\+// ? $klass : "JSON::WebToken::Crypt::$klass";
237 10 100       46 return $signing_class if $class_loaded{$signing_class};
238              
239 6 100       19 use_module $signing_class unless $class->_is_inner_package($signing_class);
240              
241 6         44 $class_loaded{$signing_class} = 1;
242 6         12 $alg_to_class{$algorithm} = $signing_class;
243              
244 6         44 return $signing_class;
245             }
246              
247             sub _is_inner_package {
248 6     6   11 my ($class, $klass) = @_;
249 8     8   44 no strict 'refs';
  8         15  
  8         1326  
250 6 100       8 %{ "$klass\::" } ? 1 : 0;
  6         76  
251             }
252              
253             ####################################################
254             # Taken from newer MIME::Base64
255             # In order to support older version of MIME::Base64
256             ####################################################
257             sub encode_base64url {
258 56     56 0 219 my $e = encode_base64(shift, "");
259 56         193 $e =~ s/=+\z//;
260 56         74 $e =~ tr[+/][-_];
261 56         161 return $e;
262             }
263              
264             sub decode_base64url {
265 55     55 0 58 my $s = shift;
266 55         66 $s =~ tr[-_][+/];
267 55         196 $s .= '=' while length($s) % 4;
268 55         263 return decode_base64($s);
269             }
270              
271             1;
272             __END__