line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::ACME2::JWTMaker; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
4
|
|
|
|
|
|
|
# This module exists because of a desire to do these computations |
5
|
|
|
|
|
|
|
# in environments where a compiler may not be available. |
6
|
|
|
|
|
|
|
# (Otherwise, CryptX would be ideal.) |
7
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
8
|
|
|
|
|
|
|
|
9
|
2
|
|
|
2
|
|
1000
|
use strict; |
|
2
|
|
|
|
|
44
|
|
|
2
|
|
|
|
|
55
|
|
10
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
77
|
|
11
|
|
|
|
|
|
|
|
12
|
2
|
|
|
2
|
|
50
|
use JSON (); |
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
53
|
|
13
|
2
|
|
|
2
|
|
14
|
use MIME::Base64 (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
29
|
|
14
|
|
|
|
|
|
|
|
15
|
2
|
|
|
2
|
|
7
|
use Net::ACME2::X (); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
58
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
BEGIN { |
18
|
2
|
|
|
2
|
|
1082
|
*_encode_b64u = *MIME::Base64::encode_base64url; |
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub new { |
22
|
12
|
|
|
12
|
0
|
46
|
my ($class, %opts) = @_; |
23
|
|
|
|
|
|
|
|
24
|
12
|
50
|
|
|
|
48
|
die Net::ACME2::X->create('Generic', 'need “key”') if !$opts{'key'}; |
25
|
|
|
|
|
|
|
|
26
|
12
|
|
|
|
|
70
|
return bless \%opts, $class; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub create_full_jws { |
30
|
24
|
|
|
24
|
0
|
117
|
my ($self, %args) = @_; |
31
|
|
|
|
|
|
|
|
32
|
24
|
|
|
|
|
126
|
local $args{'extra_headers'}{'jwk'} = $self->{'key'}->get_struct_for_public_jwk(); |
33
|
|
|
|
|
|
|
|
34
|
24
|
|
|
|
|
316903
|
return $self->_create_jwt(%args); |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub create_key_id_jws { |
38
|
0
|
|
|
0
|
0
|
0
|
my ($self, %args) = @_; |
39
|
|
|
|
|
|
|
|
40
|
0
|
|
|
|
|
0
|
local $args{'extra_headers'}{'kid'} = $args{'key_id'}; |
41
|
|
|
|
|
|
|
|
42
|
0
|
|
|
|
|
0
|
return $self->_create_jwt(%args); |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
#expects: |
48
|
|
|
|
|
|
|
# payload - unblessed string, arrayref, or hashref |
49
|
|
|
|
|
|
|
# extra_headers - hashref |
50
|
|
|
|
|
|
|
sub _create_jwt { |
51
|
24
|
|
|
24
|
|
104
|
my ( $self, %args ) = @_; |
52
|
|
|
|
|
|
|
|
53
|
24
|
|
|
|
|
131
|
my $alg = $self->_ALG(); |
54
|
24
|
|
|
|
|
250354
|
my $signer_cr = $self->_get_signer(); |
55
|
|
|
|
|
|
|
|
56
|
24
|
|
|
|
|
72
|
my $key = $self->{'key'}; |
57
|
|
|
|
|
|
|
|
58
|
24
|
|
|
|
|
60
|
my $payload = $args{payload}; |
59
|
|
|
|
|
|
|
|
60
|
24
|
|
|
|
|
46
|
my $header = { %{$args{extra_headers}} }; |
|
24
|
|
|
|
|
147
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# serialize payload |
63
|
24
|
|
|
|
|
138
|
$payload = $self->_payload_enc($payload); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# encode payload |
66
|
24
|
|
|
|
|
102
|
my $b64u_payload = _encode_b64u($payload); |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# prepare header |
69
|
24
|
|
|
|
|
351
|
$header->{alg} = $alg; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# encode header |
72
|
24
|
|
|
|
|
60
|
my $json_header = $self->_encode_json($header); |
73
|
24
|
|
|
|
|
71
|
my $b64u_header = _encode_b64u($json_header); |
74
|
|
|
|
|
|
|
|
75
|
24
|
|
|
|
|
329
|
my $b64u_signature = _encode_b64u( $signer_cr->("$b64u_header.$b64u_payload") ); |
76
|
|
|
|
|
|
|
|
77
|
24
|
|
|
|
|
198374639
|
return $self->_encode_json( |
78
|
|
|
|
|
|
|
{ |
79
|
|
|
|
|
|
|
protected => $b64u_header, |
80
|
|
|
|
|
|
|
payload => $b64u_payload, |
81
|
|
|
|
|
|
|
signature => $b64u_signature, |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
sub _encode_json { |
87
|
72
|
|
|
72
|
|
173
|
my ($self, $payload) = @_; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
#Always do a canonical encode so that we can test more easily. |
90
|
|
|
|
|
|
|
#Note that JWS itself does NOT require this. |
91
|
72
|
|
66
|
|
|
369
|
$self->{'_json'} ||= JSON->new()->canonical(1); |
92
|
|
|
|
|
|
|
|
93
|
72
|
|
|
|
|
1361
|
return $self->{'_json'}->encode($payload); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
#Derived from Crypt::JWT |
97
|
|
|
|
|
|
|
sub _payload_enc { |
98
|
24
|
|
|
24
|
|
71
|
my ($self, $payload) = @_; |
99
|
|
|
|
|
|
|
|
100
|
24
|
50
|
33
|
|
|
117
|
if (ref($payload) eq 'HASH' || ref($payload) eq 'ARRAY') { |
101
|
24
|
|
|
|
|
80
|
$payload = $self->_encode_json($payload); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
else { |
104
|
0
|
0
|
|
|
|
0
|
utf8::downgrade($payload, 1) or do { |
105
|
0
|
|
|
|
|
0
|
die Net::ACME2::X->create('Generic', "JWT: payload ($payload) cannot contain wide character"); |
106
|
|
|
|
|
|
|
}; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
24
|
|
|
|
|
65
|
return $payload; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
1; |