line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Mail::DKIM::Iterator; |
2
|
2
|
|
|
2
|
|
68951
|
use v5.10.0; |
|
2
|
|
|
|
|
14
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
our $VERSION = '1.009'; |
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
11
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
50
|
|
7
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
61
|
|
8
|
2
|
|
|
2
|
|
985
|
use Crypt::OpenSSL::RSA; |
|
2
|
|
|
|
|
13059
|
|
|
2
|
|
|
|
|
70
|
|
9
|
2
|
|
|
2
|
|
14
|
use Scalar::Util 'dualvar'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
204
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# critical header fields which should be well protected |
12
|
|
|
|
|
|
|
my @critical_headers = qw(from subject content-type content-transfer-encoding); |
13
|
|
|
|
|
|
|
my $critical_headers_rx = do { |
14
|
|
|
|
|
|
|
my $rx = join("|",@critical_headers); |
15
|
|
|
|
|
|
|
qr{$rx}i; |
16
|
|
|
|
|
|
|
}; |
17
|
|
|
|
|
|
|
# all header fields which should be included in the signature |
18
|
|
|
|
|
|
|
my @sign_headers = (@critical_headers, 'to', 'cc', 'date'); |
19
|
|
|
|
|
|
|
|
20
|
2
|
|
|
2
|
|
13
|
use Exporter 'import'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
237
|
|
21
|
|
|
|
|
|
|
our @EXPORT = qw( |
22
|
|
|
|
|
|
|
DKIM_POLICY |
23
|
|
|
|
|
|
|
DKIM_PERMERROR |
24
|
|
|
|
|
|
|
DKIM_NEUTRAL |
25
|
|
|
|
|
|
|
DKIM_TEMPERROR |
26
|
|
|
|
|
|
|
DKIM_FAIL |
27
|
|
|
|
|
|
|
DKIM_PASS |
28
|
|
|
|
|
|
|
); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
use constant { |
31
|
2
|
|
|
|
|
382
|
DKIM_POLICY => dualvar(-4,'policy'), |
32
|
|
|
|
|
|
|
DKIM_PERMERROR => dualvar(-3,'permerror'), |
33
|
|
|
|
|
|
|
DKIM_NEUTRAL => dualvar(-2,'neutral'), |
34
|
|
|
|
|
|
|
DKIM_TEMPERROR => dualvar(-1,'temperror'), |
35
|
|
|
|
|
|
|
DKIM_FAIL => dualvar( 0,'fail'), |
36
|
|
|
|
|
|
|
DKIM_PASS => dualvar( 1,'pass'), |
37
|
2
|
|
|
2
|
|
14
|
}; |
|
2
|
|
|
|
|
4
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# compability to versions 1.003 and lower |
40
|
|
|
|
|
|
|
push @EXPORT, qw( |
41
|
|
|
|
|
|
|
DKIM_INVALID_HDR |
42
|
|
|
|
|
|
|
DKIM_TEMPFAIL |
43
|
|
|
|
|
|
|
DKIM_SOFTFAIL |
44
|
|
|
|
|
|
|
DKIM_PERMFAIL |
45
|
|
|
|
|
|
|
DKIM_SUCCESS |
46
|
|
|
|
|
|
|
); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
use constant { |
49
|
2
|
|
|
|
|
9259
|
DKIM_INVALID_HDR => DKIM_PERMERROR, |
50
|
|
|
|
|
|
|
DKIM_TEMPFAIL => DKIM_TEMPERROR, |
51
|
|
|
|
|
|
|
DKIM_SOFTFAIL => DKIM_NEUTRAL, |
52
|
|
|
|
|
|
|
DKIM_PERMFAIL => DKIM_FAIL, |
53
|
|
|
|
|
|
|
DKIM_SUCCESS => DKIM_PASS, |
54
|
2
|
|
|
2
|
|
14
|
}; |
|
2
|
|
|
|
|
4
|
|
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# create new object |
58
|
|
|
|
|
|
|
sub new { |
59
|
44
|
|
|
44
|
1
|
14503
|
my ($class,%args) = @_; |
60
|
|
|
|
|
|
|
my $self = bless { |
61
|
|
|
|
|
|
|
records => $args{dns} || {}, # mapping (dnsname,dkim_key) |
62
|
|
|
|
|
|
|
extract_sig => 1, # extract signatures from mail header |
63
|
|
|
|
|
|
|
filter => $args{filter}, # filter which signatures are relevant |
64
|
|
|
|
|
|
|
# sig => [...], # list of signatures from header or to sign |
65
|
44
|
|
50
|
|
|
272
|
_hdrbuf => '', # used while collecting the mail header |
66
|
|
|
|
|
|
|
}, $class; |
67
|
|
|
|
|
|
|
|
68
|
44
|
100
|
|
|
|
129
|
if (my $sig = delete $args{sign}) { |
69
|
|
|
|
|
|
|
# signatures given for signing, either as [{},...] or {} |
70
|
|
|
|
|
|
|
# add to self.sig |
71
|
22
|
50
|
|
|
|
76
|
$sig = [$sig] if ref($sig) ne 'ARRAY'; |
72
|
22
|
|
|
|
|
41
|
$self->{extract_sig} = delete $args{sign_and_verify}; |
73
|
22
|
|
|
|
|
35
|
my $error; |
74
|
22
|
|
|
|
|
46
|
for(@$sig) { |
75
|
22
|
50
|
100
|
|
|
101
|
$_->{h} //= 'from' if ref($_); # minimal |
76
|
22
|
|
|
|
|
62
|
my $s = parse_signature($_,\$error,1); |
77
|
22
|
50
|
|
|
|
48
|
die "bad signature '$_': $error" if !$s; |
78
|
22
|
|
100
|
|
|
92
|
$s->{h_auto} //= 1; # secure version will be detected based on mail |
79
|
22
|
|
|
|
|
35
|
push @{$self->{sig}}, $s |
|
22
|
|
|
|
|
73
|
|
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
} |
82
|
44
|
|
|
|
|
126
|
return $self; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# Iterator: feed object with information and get back what to do next |
86
|
|
|
|
|
|
|
sub next { |
87
|
104
|
|
|
104
|
1
|
1051
|
my $self = shift; |
88
|
104
|
|
|
|
|
147
|
my $rv; |
89
|
104
|
|
|
|
|
209
|
while (@_) { |
90
|
104
|
|
|
|
|
183
|
my $arg = shift; |
91
|
104
|
100
|
|
|
|
202
|
if (ref($arg)) { |
92
|
|
|
|
|
|
|
# ref: mapping (host,dkim_key) |
93
|
19
|
|
|
|
|
123
|
while (my ($k,$v) = each %$arg) { |
94
|
19
|
|
|
|
|
73
|
$self->{records}{$k} = $v; |
95
|
|
|
|
|
|
|
} |
96
|
19
|
|
|
|
|
48
|
$rv = _compute_result($self); |
97
|
|
|
|
|
|
|
} else { |
98
|
|
|
|
|
|
|
# string: append data from mail |
99
|
85
|
100
|
|
|
|
162
|
if (defined $self->{_hdrbuf}) { |
100
|
|
|
|
|
|
|
# header not fully read: append and try to find end of header |
101
|
44
|
|
|
|
|
125
|
$self->{_hdrbuf} .= $arg; |
102
|
44
|
50
|
|
|
|
474
|
$self->{_hdrbuf} =~m{(\r?\n)\1}g or last; # no end of header |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Extract header into self.header and look for DKIM signatures |
105
|
|
|
|
|
|
|
# inside. The rest of _hdrbuf will be appended as part of the |
106
|
|
|
|
|
|
|
# body and the attribute _hdrbuf itself is no longer needed |
107
|
44
|
|
|
|
|
244
|
$self->{header} = substr($self->{_hdrbuf},0,$+[0],''); |
108
|
44
|
100
|
66
|
|
|
162
|
if ($self->{extract_sig} |
109
|
|
|
|
|
|
|
and my @sig = _parse_header($self->{header})) { |
110
|
22
|
50
|
|
|
|
59
|
if (my $f = $self->{filter}) { |
111
|
0
|
|
|
|
|
0
|
@sig = grep { $f->($_,$self->{header}) } @sig; |
|
0
|
|
|
|
|
0
|
|
112
|
|
|
|
|
|
|
} |
113
|
22
|
50
|
50
|
|
|
45
|
push @{$self->{sig} ||= []}, @sig if @sig; |
|
22
|
|
|
|
|
94
|
|
114
|
|
|
|
|
|
|
} |
115
|
44
|
|
|
|
|
110
|
$arg = delete $self->{_hdrbuf}; |
116
|
44
|
50
|
|
|
|
146
|
_append_body($self,$arg) if $arg ne ''; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
} else { |
119
|
|
|
|
|
|
|
# header already read: append as part of body |
120
|
41
|
|
|
|
|
83
|
_append_body($self,$arg); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
85
|
50
|
|
|
|
194
|
if (!$self->{sig}) { |
124
|
|
|
|
|
|
|
# No signatures found in body -> empty return list |
125
|
0
|
|
|
|
|
0
|
$rv = []; |
126
|
|
|
|
|
|
|
} else { |
127
|
85
|
|
|
|
|
167
|
$rv = _compute_result($self); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
} |
131
|
104
|
50
|
|
|
|
272
|
$rv = _compute_result($self) if ! @_; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# If we have no results yet just return that we need more data |
134
|
104
|
50
|
|
|
|
221
|
$rv or return ([],\''); |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Extract the DNS names for the partial results where the DKIM key is needed |
137
|
|
|
|
|
|
|
# and return the as todo. If the body hash could not yet computed for a |
138
|
|
|
|
|
|
|
# signature mark also that we need more data |
139
|
104
|
|
|
|
|
162
|
my (%need_dns,$need_more_data); |
140
|
104
|
|
|
|
|
237
|
for(@$rv) { |
141
|
104
|
100
|
|
|
|
191
|
$_->status and next; |
142
|
60
|
|
|
|
|
144
|
my $sig = $_->sig; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# Need more data to compute the body hash? |
145
|
60
|
100
|
|
|
|
136
|
$need_more_data = 1 if !$sig->{'bh:computed'}; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Need to get DKIM key to validate signature? |
148
|
|
|
|
|
|
|
# Only if we have sig.b, i.e. an extracted signature from the header. |
149
|
60
|
100
|
|
|
|
135
|
if ($sig->{b}) { |
150
|
38
|
|
|
|
|
67
|
my $name = $_->dnsname; |
151
|
38
|
50
|
|
|
|
119
|
$need_dns{$name}++ if ! $self->{records}{$name}; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# return preliminary results and @todo |
156
|
104
|
100
|
|
|
|
671
|
return ($rv,$need_more_data ? (\''):(),sort keys %need_dns); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub filter { |
160
|
0
|
|
|
0
|
1
|
0
|
my ($self,$filter) = @_; |
161
|
0
|
|
|
|
|
0
|
$self->{filter} = $filter; |
162
|
0
|
|
|
|
|
0
|
@{$self->{sig}} = grep { $filter->($_,$self->{header}) } @{$self->{sig}} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
163
|
0
|
0
|
0
|
|
|
0
|
if $self->{header} && $self->{sig}; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub result { |
167
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
168
|
0
|
|
|
|
|
0
|
return $self->{_last_result}; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
sub authentication_results { |
172
|
|
|
|
|
|
|
return join(";\n",map { |
173
|
0
|
|
|
|
|
0
|
my $ar = $_->authentication_results; |
174
|
0
|
0
|
|
|
|
0
|
$ar ? (' '.$ar) : (), |
175
|
0
|
0
|
|
0
|
1
|
0
|
} @{shift->result || []}); |
|
0
|
|
|
|
|
0
|
|
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# Compute result based on current data. |
179
|
|
|
|
|
|
|
# This might add more DKIM records to validate signatures. |
180
|
|
|
|
|
|
|
sub _compute_result { |
181
|
208
|
|
|
208
|
|
400
|
my $self = shift; |
182
|
208
|
50
|
|
|
|
428
|
return if defined $self->{_hdrbuf}; # need more header |
183
|
208
|
50
|
|
|
|
386
|
return [] if !$self->{sig}; # nothing to verify |
184
|
|
|
|
|
|
|
|
185
|
208
|
|
|
|
|
274
|
my @rv; |
186
|
208
|
|
|
|
|
284
|
for my $sig (@{$self->{sig}}) { |
|
208
|
|
|
|
|
390
|
|
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
# use final result if we have one already |
189
|
208
|
100
|
|
|
|
380
|
if ($sig->{':result'}) { |
190
|
44
|
|
|
|
|
76
|
push @rv, $sig->{':result'}; |
191
|
44
|
|
|
|
|
79
|
next; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
164
|
100
|
|
|
|
306
|
if ($sig->{error}) { |
195
|
|
|
|
|
|
|
# something wrong with the DKIM-Signature header, return error |
196
|
|
|
|
|
|
|
push @rv, $sig->{':result'} = |
197
|
|
|
|
|
|
|
Mail::DKIM::Iterator::VerifyRecord->new( |
198
|
|
|
|
|
|
|
$sig, |
199
|
|
|
|
|
|
|
($sig->{s}//'UNKNOWN')."_domainkey".($sig->{d}//'UNKNOWN'), |
200
|
|
|
|
|
|
|
DKIM_PERMERROR, |
201
|
|
|
|
|
|
|
$sig->{error} |
202
|
1
|
|
50
|
|
|
14
|
); |
|
|
|
50
|
|
|
|
|
203
|
1
|
|
|
|
|
3
|
next; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
163
|
100
|
|
|
|
297
|
if (!$sig->{b}) { |
207
|
|
|
|
|
|
|
# sig is not for verification but for signing |
208
|
66
|
100
|
|
|
|
116
|
if (!$sig->{'bh:computed'}) { |
209
|
|
|
|
|
|
|
# incomplete: still need more data to compute signature |
210
|
44
|
|
|
|
|
102
|
push @rv, Mail::DKIM::Iterator::SignRecord->new($sig); |
211
|
|
|
|
|
|
|
} else { |
212
|
|
|
|
|
|
|
# complete: compute signature and save it in :result |
213
|
22
|
|
|
|
|
32
|
my $err; |
214
|
22
|
|
|
|
|
57
|
my $dkim_sig = sign($sig,$sig->{':key'},$self->{header},\$err); |
215
|
22
|
50
|
|
|
|
99
|
push @rv, $sig->{':result'} = |
216
|
|
|
|
|
|
|
Mail::DKIM::Iterator::SignRecord->new( |
217
|
|
|
|
|
|
|
$dkim_sig ? ($sig,$dkim_sig,DKIM_PASS) |
218
|
|
|
|
|
|
|
: ($sig,undef,DKIM_FAIL,$err) |
219
|
|
|
|
|
|
|
); |
220
|
|
|
|
|
|
|
} |
221
|
66
|
|
|
|
|
144
|
next; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
97
|
|
|
|
|
255
|
my $dns = "$sig->{s}._domainkey.$sig->{d}"; |
225
|
|
|
|
|
|
|
|
226
|
97
|
100
|
66
|
|
|
215
|
if ($sig->{x} && $sig->{x} < time()) { |
227
|
1
|
|
|
|
|
6
|
push @rv, $sig->{':result'} = Mail::DKIM::Iterator::VerifyRecord |
228
|
|
|
|
|
|
|
->new($sig,$dns, DKIM_POLICY, "signature e[x]pired"); |
229
|
1
|
|
|
|
|
3
|
next; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
96
|
|
|
|
|
167
|
my $txt = $self->{records}{$dns}; |
233
|
96
|
100
|
33
|
|
|
333
|
if ($txt and !ref($txt) || ref($txt) eq 'ARRAY') { |
|
|
100
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
234
|
|
|
|
|
|
|
# Take the first syntactically valid DKIM key from the list of |
235
|
|
|
|
|
|
|
# TXT records. |
236
|
18
|
|
|
|
|
27
|
my $error = "no TXT records"; |
237
|
18
|
50
|
|
|
|
44
|
for(ref($txt) ? @$txt:$txt) { |
238
|
18
|
100
|
|
|
|
48
|
if (my $r = parse_dkimkey($_,\$error)) { |
239
|
17
|
|
|
|
|
42
|
$self->{records}{$dns} = $txt = $r; |
240
|
17
|
|
|
|
|
28
|
$error = undef; |
241
|
17
|
|
|
|
|
28
|
last; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
} |
244
|
18
|
100
|
|
|
|
42
|
$self->{records}{$dns} = $txt = { permfail => $error } |
245
|
|
|
|
|
|
|
if $error; |
246
|
|
|
|
|
|
|
} elsif (exists $self->{records}{$dns} && ! $txt) { |
247
|
1
|
|
|
|
|
3
|
$self->{records}{$dns} = $txt = { tempfail => "dns lookup failed" } |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
96
|
|
|
|
|
179
|
my @v = _verify_sig($sig,$txt); |
251
|
96
|
|
|
|
|
220
|
push @rv, Mail::DKIM::Iterator::VerifyRecord->new($sig,$dns,@v); |
252
|
96
|
100
|
|
|
|
282
|
$sig->{':result'} = $rv[-1] if @v; # we got a final result |
253
|
|
|
|
|
|
|
} |
254
|
208
|
|
|
|
|
636
|
return ($self->{_last_result} = \@rv); |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# Parse DKIM-Signature value into hash and fill in necessary default values. |
258
|
|
|
|
|
|
|
# Input can be string or hash. |
259
|
|
|
|
|
|
|
sub parse_signature { |
260
|
66
|
|
|
66
|
1
|
159
|
my ($v,$error,$for_signing) = @_; |
261
|
66
|
100
|
50
|
|
|
175
|
$v = parse_taglist($v,$error) or return if !ref($v); |
262
|
|
|
|
|
|
|
|
263
|
66
|
100
|
|
|
|
141
|
if ($for_signing) { |
264
|
|
|
|
|
|
|
# some defaults |
265
|
44
|
|
100
|
|
|
128
|
$v->{v} //= '1'; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
66
|
100
|
50
|
|
|
392
|
if (($v->{v}//'') ne '1') { |
|
|
50
|
66
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
269
|
1
|
|
50
|
|
|
6
|
$$error = "bad DKIM signature version: ".($v->{v}||''); |
270
|
|
|
|
|
|
|
} elsif (!$v->{d}) { |
271
|
0
|
|
|
|
|
0
|
$$error = "required [d]omain not given"; |
272
|
|
|
|
|
|
|
} elsif (!$v->{s}) { |
273
|
0
|
|
|
|
|
0
|
$$error = "required [s]elector not given"; |
274
|
|
|
|
|
|
|
} elsif (!$v->{h}) { |
275
|
0
|
|
|
|
|
0
|
$$error = "required [h]eader fields not given"; |
276
|
|
|
|
|
|
|
} elsif ($v->{l} && $v->{l} !~m{^\d{1,76}\z}) { |
277
|
0
|
|
|
|
|
0
|
$$error = "invalid body [l]ength"; |
278
|
|
|
|
|
|
|
} elsif (do { |
279
|
65
|
|
100
|
|
|
223
|
$v->{q} = lc($v->{q}//'dns/txt'); |
280
|
65
|
|
|
|
|
177
|
$v->{q} ne 'dns/txt' |
281
|
|
|
|
|
|
|
}) { |
282
|
0
|
|
|
|
|
0
|
$$error = "unsupported query method $v->{q}"; |
283
|
|
|
|
|
|
|
} |
284
|
66
|
100
|
|
|
|
169
|
return if $$error; |
285
|
|
|
|
|
|
|
|
286
|
65
|
|
|
|
|
118
|
$v->{d} = lc($v->{d}); |
287
|
65
|
|
100
|
|
|
179
|
$v->{a} = lc($v->{a}//'rsa-sha256'); |
288
|
65
|
|
100
|
|
|
172
|
$v->{c} = lc($v->{c}//'simple/simple'); |
289
|
|
|
|
|
|
|
|
290
|
65
|
|
|
|
|
610
|
my @h = split(/\s*:\s*/,lc($v->{h})); |
291
|
|
|
|
|
|
|
$$error = "'from' missing from [h]eader fields" |
292
|
65
|
50
|
|
|
|
148
|
if ! grep { $_ eq 'from' } @h; |
|
473
|
|
|
|
|
862
|
|
293
|
65
|
|
|
|
|
146
|
$v->{'h:list'} = \@h; |
294
|
|
|
|
|
|
|
|
295
|
65
|
100
|
|
|
|
138
|
if ($for_signing) { |
296
|
44
|
|
|
|
|
79
|
delete $v->{b}; |
297
|
44
|
|
|
|
|
55
|
delete $v->{bh}; |
298
|
44
|
50
|
|
|
|
94
|
$v->{t} = undef if exists $v->{t}; |
299
|
44
|
50
|
66
|
|
|
113
|
if (defined $v->{x} && $v->{x} !~m{^\+?\d{1,12}\z}) { |
300
|
0
|
|
|
|
|
0
|
$$error = "invalid e[x]piration time"; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
} else { |
303
|
21
|
50
|
33
|
|
|
73
|
if (!$v->{b} or not $v->{'b:bin'} = _decode64($v->{b})) { |
|
|
50
|
33
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
100
|
|
|
|
|
|
304
|
0
|
|
0
|
|
|
0
|
$$error = "invalid body signature: ".($v->{b}||''); |
305
|
|
|
|
|
|
|
} elsif (!$v->{bh} or not $v->{'bh:bin'} = _decode64($v->{bh})) { |
306
|
0
|
|
0
|
|
|
0
|
$$error = "invalid header signature: ".($v->{bh}||''); |
307
|
|
|
|
|
|
|
} elsif ($v->{t} && $v->{t} !~m{^\d{1,12}\z}) { |
308
|
0
|
|
|
|
|
0
|
$$error = "invalid [t]imestamp"; |
309
|
|
|
|
|
|
|
} elsif ($v->{x}) { |
310
|
1
|
50
|
33
|
|
|
11
|
if ($v->{x} !~m{^\d{1,12}\z}) { |
|
|
50
|
|
|
|
|
|
311
|
0
|
|
|
|
|
0
|
$$error = "invalid e[x]piration time"; |
312
|
|
|
|
|
|
|
} elsif ($v->{t} && $v->{x} < $v->{t}) { |
313
|
0
|
|
|
|
|
0
|
$$error = "expiration precedes timestamp"; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
21
|
50
|
|
|
|
48
|
if ($v->{i}) { |
318
|
0
|
|
|
|
|
0
|
$v->{i} = _decodeQP($v->{i}); |
319
|
0
|
0
|
|
|
|
0
|
if (lc($v->{i}) =~m{\@([^@]+)$}) { |
320
|
0
|
|
|
|
|
0
|
$v->{'i:domain'} = $1; |
321
|
|
|
|
|
|
|
$$error ||= "[i]dentity does not match [d]omain" |
322
|
0
|
0
|
0
|
|
|
0
|
if $v->{'i:domain'} !~m{^(.+\.)?\Q$v->{d}\E\z}; |
323
|
|
|
|
|
|
|
} else { |
324
|
0
|
|
|
|
|
0
|
$$error = "no domain in identity"; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
} else { |
327
|
21
|
|
|
|
|
54
|
$v->{i} = '@'.$v->{d}; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
my ($hdrc,$bodyc) = $v->{c} |
332
|
65
|
50
|
|
|
|
453
|
=~m{^(relaxed|simple)(?:/(relaxed|simple))?$} or do { |
333
|
0
|
|
0
|
|
|
0
|
$$error ||= "invalid canonicalization $v->{c}"; |
334
|
|
|
|
|
|
|
}; |
335
|
65
|
|
100
|
|
|
180
|
$bodyc ||= 'simple'; |
336
|
65
|
50
|
|
|
|
293
|
my ($kalgo,$halgo) = $v->{a} =~m{^(rsa)-(sha(?:1|256))$} or do { |
337
|
0
|
|
0
|
|
|
0
|
$$error ||= "unsupported algorithm $v->{a}"; |
338
|
|
|
|
|
|
|
}; |
339
|
65
|
50
|
|
|
|
148
|
return if $$error; |
340
|
|
|
|
|
|
|
|
341
|
65
|
|
|
|
|
111
|
$v->{'c:hdr'} = $hdrc; |
342
|
65
|
|
|
|
|
119
|
$v->{'c:body'} = $bodyc; |
343
|
65
|
|
|
|
|
105
|
$v->{'a:key'} = $kalgo; |
344
|
65
|
|
|
|
|
93
|
$v->{'a:hash'} = $halgo; |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# ignore: z |
347
|
65
|
|
|
|
|
182
|
return $v; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# Parse DKIM key into hash and fill in necessary default values. |
351
|
|
|
|
|
|
|
# Input can be string or hash. |
352
|
|
|
|
|
|
|
sub parse_dkimkey { |
353
|
18
|
|
|
18
|
1
|
32
|
my ($v,$error) = @_; |
354
|
18
|
50
|
50
|
|
|
49
|
$v = parse_taglist($v,$error) or return if !ref($v); |
355
|
18
|
100
|
66
|
|
|
85
|
if (!$v || !%$v) { |
356
|
1
|
|
|
|
|
3
|
$$error = "invalid or empty DKIM record"; |
357
|
1
|
|
|
|
|
4
|
return; |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
17
|
50
|
50
|
|
|
97
|
if (($v->{v}||='DKIM1') ne 'DKIM1') { |
|
|
50
|
50
|
|
|
|
|
361
|
0
|
|
|
|
|
0
|
$$error = "bad DKIM record version: $v->{v}"; |
362
|
|
|
|
|
|
|
} elsif (($v->{k}//='rsa') ne 'rsa') { |
363
|
0
|
|
|
|
|
0
|
$$error = "unsupported key type $v->{k}"; |
364
|
|
|
|
|
|
|
} else { |
365
|
17
|
50
|
|
|
|
53
|
if (exists $v->{g}) { |
366
|
|
|
|
|
|
|
# g is deprecated in RFC 6376 |
367
|
0
|
|
|
|
|
0
|
if (1) { |
368
|
|
|
|
|
|
|
delete $v->{g} |
369
|
0
|
|
|
|
|
0
|
} else { |
370
|
|
|
|
|
|
|
$v->{g} = ($v->{g}//'') =~m{^(.*)\*(.*)$} |
371
|
|
|
|
|
|
|
? qr{^\Q$1\E.*\Q$2\E\@[^@]+\z} |
372
|
|
|
|
|
|
|
: qr{^\Q$v->{g}\E\@[^@]+\z}; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
} |
375
|
17
|
|
50
|
|
|
81
|
$v->{t} = { map { $_ => 1 } split(':',lc($v->{t} || '')) }; |
|
0
|
|
|
|
|
0
|
|
376
|
17
|
|
50
|
|
|
72
|
$v->{h} = { map { $_ => 1 } split(':',lc($v->{h} || 'sha1:sha256')) }; |
|
34
|
|
|
|
|
124
|
|
377
|
17
|
|
50
|
|
|
80
|
$v->{s} = { map { $_ => 1 } split(':',lc($v->{s} || '*')) }; |
|
17
|
|
|
|
|
54
|
|
378
|
17
|
0
|
33
|
|
|
46
|
if (!$v->{s}{'*'} && !$v->{s}{email}) { |
379
|
0
|
|
|
|
|
0
|
$$error = "service type " . join(':',keys %{$v->{s}}) |
|
0
|
|
|
|
|
0
|
|
380
|
|
|
|
|
|
|
. " does not match"; |
381
|
0
|
|
|
|
|
0
|
return; |
382
|
|
|
|
|
|
|
} |
383
|
17
|
|
|
|
|
51
|
return $v; |
384
|
|
|
|
|
|
|
} |
385
|
0
|
|
|
|
|
0
|
return; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# Finalize signature, i.e add the 'b' parameter. |
389
|
|
|
|
|
|
|
# Input is signature (hash or string), the private key (PEM or |
390
|
|
|
|
|
|
|
# Crypto::OpenSSL::RSA object) and the mail header. |
391
|
|
|
|
|
|
|
# Output is "DKIM-Signature: .... " string with proper line length so that it |
392
|
|
|
|
|
|
|
# can be inserted into the mail header. |
393
|
|
|
|
|
|
|
sub sign { |
394
|
22
|
|
|
22
|
1
|
54
|
my ($sig,$key,$hdr,$error) = @_; |
395
|
22
|
100
|
66
|
|
|
111
|
if (ref($sig) && $sig->{h_auto}) { |
396
|
|
|
|
|
|
|
# add a useful default based on the header which makes sure that no all |
397
|
|
|
|
|
|
|
# relevant headers are covered and no additional important headers can |
398
|
|
|
|
|
|
|
# be added |
399
|
20
|
|
|
|
|
30
|
my (%oh,@nh); |
400
|
20
|
|
50
|
|
|
110
|
$oh{lc($_)}++ for split(':',$sig->{h} ||''); |
401
|
20
|
|
|
|
|
47
|
for my $k (@sign_headers) { |
402
|
140
|
|
|
|
|
1722
|
for($hdr =~m{^($k):}mgi) { |
403
|
80
|
|
|
|
|
192
|
push @nh,$k; # cover each instance in header |
404
|
|
|
|
|
|
|
} |
405
|
140
|
|
|
|
|
275
|
push @nh,$k; # cover non-existance so that no instance can be added |
406
|
140
|
100
|
66
|
|
|
383
|
delete $oh{$k} if exists $oh{$k} and --$oh{$k} == 0; |
407
|
|
|
|
|
|
|
} |
408
|
20
|
|
|
|
|
43
|
push @nh,($_) x $oh{$_} for keys %oh; |
409
|
20
|
|
|
|
|
100
|
$sig->{h} = join(':',@nh); |
410
|
|
|
|
|
|
|
} |
411
|
22
|
50
|
|
|
|
56
|
$sig = parse_signature($sig,$error,1) or return; |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
|
414
|
22
|
|
|
|
|
182
|
my %sig = %$sig; |
415
|
22
|
50
|
33
|
|
|
111
|
$sig{t} = time() if !$sig{t} && exists $sig{t}; |
416
|
|
|
|
|
|
|
$sig{x} = ($sig{t} || time()) + $1 |
417
|
22
|
50
|
0
|
|
|
57
|
if $sig{x} && $sig{x} =~m{^\+(\d+)$}; |
|
|
|
66
|
|
|
|
|
418
|
22
|
50
|
|
|
|
50
|
$sig{'a:key'} eq 'rsa' or do { |
419
|
0
|
|
|
|
|
0
|
$$error = "unsupported algorithm ".$sig{'a:key'}; |
420
|
0
|
|
|
|
|
0
|
return; |
421
|
|
|
|
|
|
|
}; |
422
|
22
|
|
|
|
|
33
|
delete $sig{b}; |
423
|
22
|
50
|
|
|
|
42
|
$sig{i} = _encodeQP($sig{':i'}) if $sig{':i'}; |
424
|
22
|
50
|
|
|
|
42
|
$sig{z} = _encodeQP($sig{':z'}) if $sig{':z'}; |
425
|
22
|
|
33
|
|
|
63
|
$sig{bh} = _encode64($sig{'bh:computed'} || $sig{'bh:bin'}); |
426
|
22
|
|
|
|
|
39
|
$sig{h} = join(':',@{$sig{'h:list'}}); |
|
22
|
|
|
|
|
68
|
|
427
|
|
|
|
|
|
|
|
428
|
22
|
|
|
|
|
48
|
my @v; |
429
|
22
|
|
|
|
|
58
|
for (qw(v a c d q s t x h l i z bh)) { |
430
|
286
|
|
100
|
|
|
576
|
my $v = delete $sig{$_} // next; |
431
|
178
|
|
|
|
|
432
|
push @v, "$_=$v" |
432
|
|
|
|
|
|
|
} |
433
|
22
|
|
|
|
|
130
|
for(sort keys %sig) { |
434
|
176
|
100
|
|
|
|
353
|
m{:} and next; |
435
|
22
|
|
50
|
|
|
68
|
my $v = _encodeQP(delete $sig{$_} // next); |
436
|
22
|
|
|
|
|
66
|
push @v, "$_=$v" |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
22
|
|
|
|
|
55
|
my @lines = shift(@v); |
440
|
22
|
|
|
|
|
39
|
for(@v,"b=") { |
441
|
200
|
|
|
|
|
260
|
$lines[-1] .= ';'; |
442
|
200
|
|
|
|
|
321
|
my $append = " $_"; |
443
|
200
|
100
|
|
|
|
348
|
my $x80 = (@lines == 1 ? 64 : 80) - length($lines[-1]); |
444
|
200
|
100
|
|
|
|
370
|
if (length($append)<=$x80) { |
|
|
100
|
|
|
|
|
|
445
|
159
|
|
|
|
|
300
|
$lines[-1] .= $append; |
446
|
|
|
|
|
|
|
} elsif (length($append)<=80) { |
447
|
21
|
|
|
|
|
43
|
push @lines,$append; |
448
|
|
|
|
|
|
|
} else { |
449
|
20
|
|
|
|
|
29
|
while (1) { |
450
|
44
|
100
|
|
|
|
91
|
if ( $x80>10) { |
451
|
40
|
|
|
|
|
95
|
$lines[-1] .= substr($append,0,$x80,''); |
452
|
40
|
100
|
|
|
|
98
|
$append eq '' and last; |
453
|
|
|
|
|
|
|
} |
454
|
24
|
|
|
|
|
40
|
push @lines,' '; |
455
|
24
|
|
|
|
|
35
|
$x80 = 80; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
22
|
|
|
|
|
66
|
my $dkh = 'DKIM-Signature: '.join("\r\n",@lines); |
461
|
22
|
50
|
|
|
|
64
|
$sig->{'a:key'} eq 'rsa' or do { |
462
|
0
|
|
|
|
|
0
|
$$error = "unsupported signature algorithm $sig->{'a:key'}"; |
463
|
0
|
|
|
|
|
0
|
return; |
464
|
|
|
|
|
|
|
}; |
465
|
|
|
|
|
|
|
my $hash = _compute_hdrhash($hdr, |
466
|
22
|
|
|
|
|
58
|
$sig{'h:list'},$sig->{'a:hash'},$sig->{'c:hdr'},$dkh); |
467
|
|
|
|
|
|
|
|
468
|
22
|
50
|
|
|
|
758
|
my $priv = ref($key) ? $key : Crypt::OpenSSL::RSA->new_private_key($key); |
469
|
22
|
50
|
|
|
|
76
|
$priv or do { |
470
|
0
|
|
|
|
|
0
|
$$error = "using private key failed"; |
471
|
0
|
|
|
|
|
0
|
return; |
472
|
|
|
|
|
|
|
}; |
473
|
22
|
|
|
|
|
68
|
$priv->use_no_padding; |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
my $data = _encode64($priv->decrypt( |
476
|
22
|
|
|
|
|
94
|
_emsa_pkcs1_v15($sig->{'a:hash'},$hash,$priv->size))); |
477
|
|
|
|
|
|
|
|
478
|
22
|
|
33
|
|
|
272
|
my $x80 = 80 - ($dkh =~m{\n([^\n]+)\z} && length($1)); |
479
|
22
|
|
|
|
|
63
|
while ($data ne '') { |
480
|
77
|
100
|
|
|
|
208
|
$dkh .= substr($data,0,$x80,'') if $x80>10; |
481
|
77
|
100
|
|
|
|
158
|
$dkh .= "\r\n " if $data ne ''; |
482
|
77
|
|
|
|
|
133
|
$x80 = 80; |
483
|
|
|
|
|
|
|
} |
484
|
22
|
|
|
|
|
34
|
$dkh .= "\r\n"; |
485
|
22
|
|
|
|
|
329
|
return $dkh; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# Verify a DKIM signature (hash from parse_signature) using a DKIM key (hash |
489
|
|
|
|
|
|
|
# from parse_dkimkey). Output is (error_code,error_string) or simply |
490
|
|
|
|
|
|
|
# (DKIM_PASS) in case of no error or () if no final result can be computed yet. |
491
|
|
|
|
|
|
|
sub _verify_sig { |
492
|
96
|
|
|
96
|
|
168
|
my ($sig,$param) = @_; |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# check pre-computed hash over body if body done |
495
|
96
|
100
|
100
|
|
|
362
|
if (defined $sig->{'bh:computed'} |
496
|
|
|
|
|
|
|
and $sig->{'bh:computed'} ne $sig->{'bh:bin'}) { |
497
|
1
|
|
|
|
|
5
|
return (DKIM_FAIL, 'body hash mismatch'); |
498
|
|
|
|
|
|
|
} |
499
|
95
|
100
|
|
|
|
217
|
return if ! $param; |
500
|
|
|
|
|
|
|
|
501
|
19
|
50
|
|
|
|
46
|
return (DKIM_PERMERROR,"none or invalid dkim record") if ! %$param; |
502
|
19
|
100
|
|
|
|
40
|
return (DKIM_TEMPERROR,$param->{tempfail}) if $param->{tempfail}; |
503
|
18
|
100
|
|
|
|
41
|
return (DKIM_PERMERROR,$param->{permfail}) if $param->{permfail}; |
504
|
|
|
|
|
|
|
|
505
|
17
|
50
|
|
|
|
40
|
my $FAIL = $param->{t}{y} ? DKIM_NEUTRAL : DKIM_FAIL; |
506
|
17
|
50
|
|
|
|
46
|
return ($FAIL,"key revoked") if ! $param->{p}; |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
return ($FAIL,"hash algorithm not allowed") |
509
|
17
|
50
|
|
|
|
47
|
if ! $param->{h}{$sig->{'a:hash'}}; |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
return ($FAIL,"identity does not match domain") if $param->{t}{s} |
512
|
17
|
0
|
33
|
|
|
37
|
&& $sig->{'i:domain'} && $sig->{'i:domain'} ne $sig->{d}; |
|
|
|
0
|
|
|
|
|
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
return ($FAIL,"identity does not match granularity") |
515
|
17
|
50
|
33
|
|
|
37
|
if $param->{g} && $sig->{i} !~ $param->{g}; |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# needs bh:computed to continue |
518
|
17
|
50
|
|
|
|
35
|
return if ! defined $sig->{'bh:computed'}; |
519
|
|
|
|
|
|
|
|
520
|
17
|
100
|
|
|
|
29
|
if (!eval { |
521
|
17
|
50
|
|
|
|
24
|
my $rsa = Crypt::OpenSSL::RSA->new_public_key(do { |
522
|
17
|
|
|
|
|
31
|
local $_ = $param->{p}; |
523
|
17
|
|
|
|
|
50
|
s{\s+}{}g; |
524
|
17
|
|
|
|
|
166
|
s{(.{1,64})}{$1\n}g; |
525
|
17
|
|
|
|
|
536
|
"-----BEGIN PUBLIC KEY-----\n$_-----END PUBLIC KEY-----\n"; |
526
|
|
|
|
|
|
|
}) or die [DKIM_PERMERROR,"using public key failed"]; |
527
|
16
|
|
|
|
|
1248
|
$rsa->use_no_padding; |
528
|
16
|
100
|
|
|
|
26
|
my $bencrypt = eval { $rsa->encrypt($sig->{'b:bin'}) } |
|
16
|
|
|
|
|
674
|
|
529
|
|
|
|
|
|
|
or die [DKIM_PERMERROR,"header sig corrupt"]; |
530
|
|
|
|
|
|
|
my $expect = _emsa_pkcs1_v15( |
531
|
15
|
|
|
|
|
64
|
$sig->{'a:hash'},$sig->{'h:hash'},$rsa->size); |
532
|
15
|
100
|
|
|
|
43
|
if ($expect ne $bencrypt) { |
533
|
|
|
|
|
|
|
# warn "expect= "._encode64($expect)."\n"; |
534
|
|
|
|
|
|
|
# warn "encrypt="._encode64($bencrypt)."\n"; |
535
|
1
|
|
|
|
|
10
|
die [$FAIL,"header sig mismatch"]; |
536
|
|
|
|
|
|
|
} |
537
|
14
|
|
|
|
|
80
|
1; |
538
|
|
|
|
|
|
|
}) { |
539
|
3
|
100
|
|
|
|
39
|
return @{$@} if ref($@); |
|
2
|
|
|
|
|
11
|
|
540
|
1
|
|
|
|
|
5
|
return (DKIM_PERMERROR,"using public key failed"); |
541
|
|
|
|
|
|
|
} |
542
|
14
|
100
|
|
|
|
28
|
return (DKIM_PASS, join(' + ', @{$sig->{':warning'} || []})); |
|
14
|
|
|
|
|
89
|
|
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# parse the header and extract |
546
|
|
|
|
|
|
|
sub _parse_header { |
547
|
22
|
|
|
22
|
|
40
|
my $hdr = shift; |
548
|
22
|
|
|
|
|
50
|
my %all_critical = map { $_ => 0 } @critical_headers; |
|
88
|
|
|
|
|
203
|
|
549
|
22
|
|
|
|
|
353
|
$all_critical{lc($_)}-- for $hdr =~m{^($critical_headers_rx):}mig; |
550
|
22
|
|
|
|
|
54
|
my @sig; |
551
|
22
|
|
|
|
|
155
|
while ( $hdr =~m{^(DKIM-Signature:\s*(.*\n(?:[ \t].*\n)*))}mig ) { |
552
|
22
|
|
|
|
|
73
|
my $dkh = $1; # original value to exclude it when computing hash |
553
|
|
|
|
|
|
|
|
554
|
22
|
|
|
|
|
30
|
my $error; |
555
|
22
|
|
|
|
|
57
|
my $sig = parse_signature($2,\$error); |
556
|
22
|
100
|
|
|
|
53
|
if ($sig) { |
557
|
|
|
|
|
|
|
$sig->{'h:hash'} = _compute_hdrhash($hdr, |
558
|
21
|
|
|
|
|
59
|
$sig->{'h:list'},$sig->{'a:hash'},$sig->{'c:hdr'},$dkh); |
559
|
|
|
|
|
|
|
|
560
|
21
|
|
|
|
|
98
|
my %critical = %all_critical; |
561
|
21
|
|
|
|
|
39
|
$critical{$_}++ for @{$sig->{'h:list'}}; |
|
21
|
|
|
|
|
137
|
|
562
|
21
|
100
|
|
|
|
64
|
if (my @h = grep { $critical{$_} < 0 } keys %critical) { |
|
155
|
|
|
|
|
320
|
|
563
|
2
|
|
|
|
|
4
|
push @{$sig->{':warning'}}, |
|
2
|
|
|
|
|
29
|
|
564
|
|
|
|
|
|
|
"unprotected critical header ".join(",",sort @h); |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
} else { |
567
|
1
|
|
|
|
|
5
|
$sig = { error => "invalid DKIM-Signature header: $error" }; |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
22
|
|
|
|
|
111
|
push @sig,$sig; |
571
|
|
|
|
|
|
|
} |
572
|
22
|
|
|
|
|
125
|
return @sig; |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
{ |
576
|
|
|
|
|
|
|
# EMSA-PKCS1-v1_5 encapsulation, see RFC 3447 9.2 |
577
|
|
|
|
|
|
|
my %sig_prefix = ( |
578
|
|
|
|
|
|
|
'sha1' => pack("H*","3021300906052B0E03021A05000414"), |
579
|
|
|
|
|
|
|
'sha256' => pack("H*","3031300d060960864801650304020105000420"), |
580
|
|
|
|
|
|
|
); |
581
|
|
|
|
|
|
|
sub _emsa_pkcs1_v15 { |
582
|
37
|
|
|
37
|
|
94
|
my ($algo,$hash,$len) = @_; |
583
|
37
|
|
50
|
|
|
124
|
my $t = ($sig_prefix{$algo} || die "unsupport digest $algo") . $hash; |
584
|
37
|
|
|
|
|
80
|
my $pad = $len - length($t) -3; |
585
|
37
|
50
|
|
|
|
78
|
$pad < 8 and die; |
586
|
37
|
|
|
|
|
13860
|
return "\x00\x01" . ("\xff" x $pad) . "\x00" . $t; |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
{ |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# simple header canonicalization: |
593
|
|
|
|
|
|
|
my $simple_hdrc = sub { |
594
|
|
|
|
|
|
|
my $line = shift; |
595
|
|
|
|
|
|
|
$line =~s{(?
|
596
|
|
|
|
|
|
|
return $line; |
597
|
|
|
|
|
|
|
}; |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# relaxed header canonicalization: |
600
|
|
|
|
|
|
|
my $relaxed_hdrc = sub { |
601
|
|
|
|
|
|
|
my ($k,$v) = shift() =~m{\A([^:]+:[ \t]*)?(.*)\z}s; |
602
|
|
|
|
|
|
|
$v =~s{\r?\n([ \t])}{$1}g; # unfold lines |
603
|
|
|
|
|
|
|
$v =~s{[ \t]+}{ }g; # WSP+ -> SP |
604
|
|
|
|
|
|
|
$v =~s{\s+\z}{\r\n}; # eliminate all WS from end, normalize line end |
605
|
|
|
|
|
|
|
$k = lc($k||''); # lower case key |
606
|
|
|
|
|
|
|
$k=~s{[ \t]*:[ \t]*}{:}; # remove white-space around colon |
607
|
|
|
|
|
|
|
return $k.$v; |
608
|
|
|
|
|
|
|
}; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
my %hdrc = ( |
611
|
|
|
|
|
|
|
simple => $simple_hdrc, |
612
|
|
|
|
|
|
|
relaxed => $relaxed_hdrc, |
613
|
|
|
|
|
|
|
); |
614
|
|
|
|
|
|
|
|
615
|
2
|
|
|
2
|
|
1104
|
use Digest::SHA; |
|
2
|
|
|
|
|
6157
|
|
|
2
|
|
|
|
|
4495
|
|
616
|
|
|
|
|
|
|
my %digest = ( |
617
|
|
|
|
|
|
|
sha1 => sub { Digest::SHA->new(1) }, |
618
|
|
|
|
|
|
|
sha256 => sub { Digest::SHA->new(256) }, |
619
|
|
|
|
|
|
|
); |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# compute the hash over the header |
622
|
|
|
|
|
|
|
sub _compute_hdrhash { |
623
|
43
|
|
|
43
|
|
111
|
my ($hdr,$headers,$hash,$canon,$dkh) = @_; |
624
|
|
|
|
|
|
|
#warn "XXX $hash | $canon"; |
625
|
43
|
|
|
|
|
104
|
$hash = $digest{$hash}(); |
626
|
43
|
|
|
|
|
572
|
$canon = $hdrc{$canon}; |
627
|
43
|
|
|
|
|
64
|
my @hdr; |
628
|
|
|
|
|
|
|
my %kv; |
629
|
43
|
|
|
|
|
91
|
for my $k (@$headers) { |
630
|
445
|
50
|
|
|
|
787
|
if ($k eq 'dkim-signature') { |
631
|
0
|
|
|
|
|
0
|
for($hdr =~m{^($k:[^\n]*\n(?:[ \t][^\n]*\n)*)}mig) { |
632
|
0
|
0
|
|
|
|
0
|
$_ eq $dkh and next; |
633
|
0
|
|
|
|
|
0
|
push @hdr,$_; |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
} else { |
636
|
445
|
|
100
|
|
|
6936
|
my $v = $kv{$k} ||= |
637
|
|
|
|
|
|
|
[ $hdr =~m{^($k:[^\n]*\n(?:[ \t][^\n]*\n)*)}mig ]; |
638
|
|
|
|
|
|
|
# take last matching kv in mail header |
639
|
445
|
|
100
|
|
|
1683
|
push @hdr, pop(@$v) // ''; |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
} |
642
|
43
|
|
|
|
|
218
|
$dkh =~s{([ \t;:]b=)([a-zA-Z0-9/+= \t\r\n]+)}{$1}; |
643
|
43
|
|
|
|
|
181
|
$dkh =~s{[\r\n]+\z}{}; |
644
|
43
|
|
|
|
|
85
|
push @hdr,$dkh; |
645
|
43
|
|
|
|
|
120
|
$_ = $canon->($_) for (@hdr); |
646
|
|
|
|
|
|
|
#warn Dumper(\@hdr); use Data::Dumper; |
647
|
43
|
|
|
|
|
323
|
$hash->add(@hdr); |
648
|
43
|
|
|
|
|
435
|
return $hash->digest; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# simple body canonicalization: |
652
|
|
|
|
|
|
|
# - normalize to \r\n line end |
653
|
|
|
|
|
|
|
# - remove all empty lines at the end |
654
|
|
|
|
|
|
|
# - make sure that body consists at least of a single empty line |
655
|
|
|
|
|
|
|
# relaxed body canonicalization: |
656
|
|
|
|
|
|
|
# - like simple, but additionally... |
657
|
|
|
|
|
|
|
# - remove any white-space at the end of a line (excluding \r\n) |
658
|
|
|
|
|
|
|
# - compact any white-space inside the line to a single space |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
my $bodyc = sub { |
661
|
|
|
|
|
|
|
my $relaxed = shift; |
662
|
|
|
|
|
|
|
my $empty = my $no_line_yet = ''; |
663
|
|
|
|
|
|
|
my $realdata; |
664
|
|
|
|
|
|
|
sub { |
665
|
|
|
|
|
|
|
my $data = shift; |
666
|
|
|
|
|
|
|
if ($data eq '') { |
667
|
|
|
|
|
|
|
return $no_line_yet if $realdata; |
668
|
|
|
|
|
|
|
return "\r\n"; |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
my $nl = rindex($data,"\n"); |
671
|
|
|
|
|
|
|
if ($nl == -1) { |
672
|
|
|
|
|
|
|
$no_line_yet .= $data; |
673
|
|
|
|
|
|
|
return ''; |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
if ($nl == length($data)-1) { |
677
|
|
|
|
|
|
|
# newline at end of data |
678
|
|
|
|
|
|
|
$data = $no_line_yet . $data if $no_line_yet ne ''; |
679
|
|
|
|
|
|
|
$no_line_yet = ''; |
680
|
|
|
|
|
|
|
} else { |
681
|
|
|
|
|
|
|
# newline somewhere inside |
682
|
|
|
|
|
|
|
$no_line_yet .= substr($data,0,$nl+1,''); |
683
|
|
|
|
|
|
|
($data,$no_line_yet) = ($no_line_yet,$data); |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
$data =~s{(?
|
687
|
|
|
|
|
|
|
if ($relaxed) { |
688
|
|
|
|
|
|
|
$data =~s{[ \t]+}{ }g; # compact WSP+ to SP |
689
|
|
|
|
|
|
|
$data =~s{ \r\n}{\r\n}g; # remove WSP+ at eol |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
if ($data =~m{(^|\n)(?:\r\n)+\z}) { |
693
|
|
|
|
|
|
|
if (!$+[1]) { |
694
|
|
|
|
|
|
|
# everything empty |
695
|
|
|
|
|
|
|
$empty .= $data; |
696
|
|
|
|
|
|
|
return ''; |
697
|
|
|
|
|
|
|
} else { |
698
|
|
|
|
|
|
|
# part empty |
699
|
|
|
|
|
|
|
$empty .= substr($data,0,$+[1],''); |
700
|
|
|
|
|
|
|
($empty,$data) = ($data,$empty); |
701
|
|
|
|
|
|
|
} |
702
|
|
|
|
|
|
|
} else { |
703
|
|
|
|
|
|
|
# nothing empty |
704
|
|
|
|
|
|
|
if ($empty ne '') { |
705
|
|
|
|
|
|
|
$data = $empty . $data; |
706
|
|
|
|
|
|
|
$empty = ''; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
$realdata = 1; |
710
|
|
|
|
|
|
|
return $data; |
711
|
|
|
|
|
|
|
}; |
712
|
|
|
|
|
|
|
}; |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
my %bodyc = ( |
715
|
|
|
|
|
|
|
simple => sub { $bodyc->(0) }, |
716
|
|
|
|
|
|
|
relaxed => sub { $bodyc->(1) }, |
717
|
|
|
|
|
|
|
); |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
# add data to the body |
720
|
|
|
|
|
|
|
sub _append_body { |
721
|
85
|
|
|
85
|
|
195
|
my ($self,$buf) = @_; |
722
|
85
|
|
|
|
|
117
|
for my $sig (@{$self->{sig}}) { |
|
85
|
|
|
|
|
176
|
|
723
|
85
|
50
|
|
|
|
170
|
$sig->{'bh:computed'} and next; |
724
|
85
|
|
66
|
|
|
204
|
my $bh = $sig->{'bh:collecting'} ||= do { |
725
|
44
|
100
|
66
|
|
|
167
|
if (!$sig->{error} and |
|
|
|
66
|
|
|
|
|
726
|
|
|
|
|
|
|
my $digest = $digest{$sig->{'a:hash'}}() and |
727
|
|
|
|
|
|
|
my $transform = $bodyc{$sig->{'c:body'}}() |
728
|
|
|
|
|
|
|
) { |
729
|
|
|
|
|
|
|
{ |
730
|
|
|
|
|
|
|
digest => $digest, |
731
|
|
|
|
|
|
|
transform => $transform, |
732
|
|
|
|
|
|
|
$sig->{l} ? (l => $sig->{l}) : |
733
|
43
|
100
|
|
|
|
224
|
defined($sig->{l}) ? (l => \$sig->{l}) : # capture l |
|
|
100
|
|
|
|
|
|
734
|
|
|
|
|
|
|
(), |
735
|
|
|
|
|
|
|
}; |
736
|
|
|
|
|
|
|
} else { |
737
|
1
|
|
|
|
|
5
|
{ done => 1 }; |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
}; |
740
|
|
|
|
|
|
|
|
741
|
85
|
100
|
|
|
|
174
|
$bh->{done} and next; |
742
|
84
|
100
|
|
|
|
187
|
if ($buf eq '') { |
743
|
41
|
|
|
|
|
65
|
$bh->{done} = 1; |
744
|
41
|
|
|
|
|
160
|
goto compute_signature; |
745
|
|
|
|
|
|
|
} |
746
|
43
|
|
|
|
|
86
|
my $tbuf = $bh->{transform}($buf); |
747
|
43
|
50
|
|
|
|
86
|
$tbuf eq '' and next; |
748
|
|
|
|
|
|
|
{ |
749
|
43
|
100
|
|
|
|
82
|
defined $bh->{l} or last; |
|
43
|
|
|
|
|
106
|
|
750
|
2
|
100
|
|
|
|
8
|
if (ref $bh->{l}) { |
751
|
1
|
|
|
|
|
3
|
${$bh->{l}} += length($tbuf); |
|
1
|
|
|
|
|
6
|
|
752
|
1
|
|
|
|
|
2
|
next; |
753
|
|
|
|
|
|
|
} |
754
|
1
|
50
|
|
|
|
5
|
if ($bh->{l} > 0) { |
755
|
1
|
50
|
|
|
|
5
|
last if ($bh->{l} -= length($tbuf))>0; |
756
|
|
|
|
|
|
|
$bh->{_data_after_l} ||= |
757
|
1
|
|
33
|
|
|
13
|
substr($tbuf,$bh->{l},-$bh->{l},'') =~m{\S} & 1; |
758
|
1
|
|
|
|
|
2
|
$bh->{l} = 0; |
759
|
|
|
|
|
|
|
} else { |
760
|
0
|
|
0
|
|
|
0
|
$bh->{_data_after_l} ||= $tbuf =~m{\S} & 1; |
761
|
0
|
|
|
|
|
0
|
$tbuf = ''; |
762
|
|
|
|
|
|
|
} |
763
|
1
|
|
|
|
|
2
|
$bh->{done} = 1; |
764
|
|
|
|
|
|
|
} |
765
|
43
|
50
|
|
|
|
197
|
$bh->{digest}->add($tbuf) if $tbuf ne ''; |
766
|
43
|
100
|
|
|
|
131
|
$bh->{done} or next; |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
compute_signature: |
769
|
42
|
|
|
|
|
77
|
delete $sig->{'bh:collecting'}; |
770
|
42
|
|
|
|
|
268
|
$sig->{'bh:computed'} = $bh->{digest}->digest; |
771
|
1
|
|
|
|
|
13
|
push @{$sig->{':warning'}}, 'data after signed body' |
772
|
42
|
100
|
|
|
|
512
|
if $bh->{_data_after_l}; |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
} |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
{ |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# parse_taglist($val,\$error) |
780
|
|
|
|
|
|
|
# Parse a tag-list, like in the DKIM signature and in the DKIM key. |
781
|
|
|
|
|
|
|
# Returns a hash of the parsed list. If error occur $error will be set and |
782
|
|
|
|
|
|
|
# undef will be returned. |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
my $fws = qr{ |
785
|
|
|
|
|
|
|
[ \t]+ (?:\r?\n[ \t]+)? | |
786
|
|
|
|
|
|
|
\r?\n[ \t]+ |
787
|
|
|
|
|
|
|
}x; |
788
|
|
|
|
|
|
|
my $tagname = qr{[a-z]\w*}i; |
789
|
|
|
|
|
|
|
my $tval = qr{[\x21-\x3a\x3c-\x7e]+}; |
790
|
|
|
|
|
|
|
my $tagval = qr{$tval(?:$fws$tval)*}; |
791
|
|
|
|
|
|
|
my $end = qr{(?:\r?\n)?\z}; |
792
|
|
|
|
|
|
|
my $delim_or_end = qr{ $fws? (?: $end | ; (?: $fws?$end|)) }x; |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
sub parse_taglist { |
795
|
40
|
|
|
40
|
1
|
74
|
my ($v,$error) = @_; |
796
|
40
|
|
|
|
|
48
|
my %v; |
797
|
40
|
|
|
|
|
674
|
while ( $v =~m{\G $fws? (?: |
798
|
|
|
|
|
|
|
($tagname) $fws?=$fws? ($tagval?) $delim_or_end | |
799
|
|
|
|
|
|
|
| (.+) |
800
|
|
|
|
|
|
|
)}xgcs) { |
801
|
295
|
50
|
|
|
|
698
|
if (defined $3) { |
802
|
0
|
|
|
|
|
0
|
$$error = "invalid data at end: '$3'"; |
803
|
0
|
|
|
|
|
0
|
return; |
804
|
|
|
|
|
|
|
} |
805
|
295
|
100
|
|
|
|
544
|
last if ! defined $1; |
806
|
255
|
50
|
|
|
|
499
|
exists($v{$1}) && do { |
807
|
0
|
|
|
|
|
0
|
$$error = "duplicate key $1"; |
808
|
0
|
|
|
|
|
0
|
return; |
809
|
|
|
|
|
|
|
}; |
810
|
255
|
|
|
|
|
2736
|
$v{$1} = $2; |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
#warn Dumper(\%v); use Data::Dumper; |
813
|
40
|
|
|
|
|
146
|
return \%v; |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
} |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
sub _encode64 { |
818
|
44
|
|
|
44
|
|
114
|
my $data = shift; |
819
|
44
|
|
|
|
|
113
|
my $pad = ( 3 - length($data) % 3 ) % 3; |
820
|
44
|
|
|
|
|
172
|
$data = pack('u',$data); |
821
|
44
|
|
|
|
|
796
|
$data =~s{(^.|\n)}{}mg; |
822
|
44
|
|
|
|
|
110
|
$data =~tr{` -_}{AA-Za-z0-9+/}; |
823
|
44
|
50
|
|
|
|
150
|
substr($data,-$pad) = '=' x $pad if $pad; |
824
|
44
|
|
|
|
|
113
|
return $data; |
825
|
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
sub _decode64 { |
828
|
42
|
|
|
42
|
|
84
|
my $data = shift; |
829
|
42
|
|
|
|
|
165
|
$data =~s{\s+}{}g; |
830
|
42
|
|
|
|
|
149
|
$data =~s{=+$}{}; |
831
|
42
|
|
|
|
|
85
|
$data =~tr{A-Za-z0-9+/}{`!-_}; |
832
|
42
|
|
|
|
|
137
|
$data =~s{(.{1,60})}{ chr(32 + length($1)*3/4) . $1 . "\n" }eg; |
|
82
|
|
|
|
|
430
|
|
833
|
42
|
|
|
|
|
340
|
return unpack("u",$data); |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
sub _encodeQP { |
837
|
22
|
|
|
22
|
|
59
|
(my $data = shift) |
838
|
0
|
|
|
|
|
0
|
=~s{([^\x21-\x3a\x3c\x3e-\x7e])}{ sprintf('=%02X',ord($1)) }esg; |
839
|
22
|
|
|
|
|
53
|
return $data; |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
sub _decodeQP { |
843
|
0
|
|
|
0
|
|
0
|
my $data = shift; |
844
|
0
|
|
|
|
|
0
|
$data =~s{\s+}{}g; |
845
|
0
|
|
|
|
|
0
|
$data =~s{=([0-9A-F][0-9A-F])}{ chr(hex($1)) }esg; |
|
0
|
|
|
|
|
0
|
|
846
|
0
|
|
|
|
|
0
|
return $data; |
847
|
|
|
|
|
|
|
} |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
# ResultRecord for verification. |
851
|
|
|
|
|
|
|
package Mail::DKIM::Iterator::VerifyRecord; |
852
|
|
|
|
|
|
|
sub new { |
853
|
98
|
|
|
98
|
|
154
|
my $class = shift; |
854
|
98
|
|
|
|
|
286
|
bless [@_],$class; |
855
|
|
|
|
|
|
|
} |
856
|
38
|
|
|
38
|
|
69
|
sub sig { shift->[0] } |
857
|
0
|
|
|
0
|
|
0
|
sub domain { shift->[0]{d} } |
858
|
38
|
|
|
38
|
|
63
|
sub dnsname { shift->[1] } |
859
|
90
|
|
|
90
|
|
371
|
sub status { shift->[2] } |
860
|
8
|
50
|
|
8
|
|
37
|
sub error { $_[0]->[2] >0 ? undef : $_[0]->[3] } |
861
|
16
|
50
|
|
16
|
|
108
|
sub warning { $_[0]->[2] >0 ? $_[0]->[3] : undef } |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
sub authentication_results { |
864
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
865
|
0
|
0
|
|
|
|
0
|
return if ! $self->[2]; |
866
|
0
|
|
|
|
|
0
|
my $ar = "dkim=$self->[2]"; |
867
|
0
|
0
|
0
|
|
|
0
|
$ar .= " ($self->[3])" if defined $self->[3] and $self->[3] ne ''; |
868
|
0
|
|
0
|
|
|
0
|
$ar .= " header.d=".( $self->[0]{d} // 'unknown'); |
869
|
0
|
|
|
|
|
0
|
return $ar; |
870
|
|
|
|
|
|
|
} |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
# ResultRecord for signing. |
873
|
|
|
|
|
|
|
package Mail::DKIM::Iterator::SignRecord; |
874
|
|
|
|
|
|
|
sub new { |
875
|
66
|
|
|
66
|
|
108
|
my $class = shift; |
876
|
66
|
|
|
|
|
253
|
bless [@_],$class; |
877
|
|
|
|
|
|
|
} |
878
|
22
|
|
|
22
|
|
61
|
sub sig { shift->[0] } |
879
|
0
|
|
|
0
|
|
0
|
sub domain { shift->[0]{d} } |
880
|
|
|
|
|
|
|
sub dnsname { |
881
|
0
|
|
|
0
|
|
0
|
my $sig = shift->[0]; |
882
|
0
|
|
0
|
|
|
0
|
return ($sig->{s} || 'UNKNOWN').'_domainkey'.($sig->{d} || 'UNKNOWN'); |
|
|
|
0
|
|
|
|
|
883
|
|
|
|
|
|
|
} |
884
|
22
|
|
|
22
|
|
96
|
sub signature { shift->[1] } |
885
|
66
|
|
|
66
|
|
369
|
sub status { shift->[2] } |
886
|
0
|
|
|
0
|
|
|
sub error { shift->[3] } |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
1; |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
__END__ |