blib/lib/Mail/SPF/Server.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 81 | 158 | 51.2 |
branch | 16 | 46 | 34.7 |
condition | 3 | 24 | 12.5 |
subroutine | 24 | 44 | 54.5 |
pod | 9 | 12 | 75.0 |
total | 133 | 284 | 46.8 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # | ||||||
2 | # Mail::SPF::Server | ||||||
3 | # Server class for processing SPF requests. | ||||||
4 | # | ||||||
5 | # (C) 2005-2012 Julian Mehnle |
||||||
6 | # 2005 Shevek |
||||||
7 | # $Id: Server.pm 61 2013-07-22 03:45:15Z julian $ | ||||||
8 | # | ||||||
9 | ############################################################################## | ||||||
10 | |||||||
11 | package Mail::SPF::Server; | ||||||
12 | |||||||
13 | =head1 NAME | ||||||
14 | |||||||
15 | Mail::SPF::Server - Server class for processing SPF requests | ||||||
16 | |||||||
17 | =cut | ||||||
18 | |||||||
19 | 3 | 3 | 1282399 | use warnings; | |||
3 | 7 | ||||||
3 | 106 | ||||||
20 | 3 | 3 | 20 | use strict; | |||
3 | 6 | ||||||
3 | 113 | ||||||
21 | |||||||
22 | 3 | 3 | 15 | use base 'Mail::SPF::Base'; | |||
3 | 8 | ||||||
3 | 1316 | ||||||
23 | |||||||
24 | 3 | 3 | 19 | use Error ':try'; | |||
3 | 7 | ||||||
3 | 19 | ||||||
25 | 3 | 3 | 1600 | use Net::DNS::Resolver; | |||
3 | 95206 | ||||||
3 | 99 | ||||||
26 | |||||||
27 | 3 | 3 | 1546 | use Mail::SPF::MacroString; | |||
3 | 11 | ||||||
3 | 136 | ||||||
28 | 3 | 3 | 1443 | use Mail::SPF::Record; | |||
3 | 8 | ||||||
3 | 98 | ||||||
29 | 3 | 3 | 2145 | use Mail::SPF::Result; | |||
3 | 10 | ||||||
3 | 25 | ||||||
30 | |||||||
31 | 3 | 3 | 180 | use constant TRUE => (0 == 0); | |||
3 | 6 | ||||||
3 | 178 | ||||||
32 | 3 | 3 | 18 | use constant FALSE => not TRUE; | |||
3 | 7 | ||||||
3 | 171 | ||||||
33 | |||||||
34 | 3 | 211 | use constant record_classes_by_version => { | ||||
35 | 1 => 'Mail::SPF::v1::Record', | ||||||
36 | 2 => 'Mail::SPF::v2::Record' | ||||||
37 | 3 | 3 | 19 | }; | |||
3 | 6 | ||||||
38 | |||||||
39 | 3 | 3 | 18 | use constant result_base_class => 'Mail::SPF::Result'; | |||
3 | 7 | ||||||
3 | 156 | ||||||
40 | |||||||
41 | 3 | 3 | 19 | use constant query_rr_type_all => 0; | |||
3 | 5 | ||||||
3 | 165 | ||||||
42 | 3 | 3 | 18 | use constant query_rr_type_txt => 1; | |||
3 | 7 | ||||||
3 | 136 | ||||||
43 | 3 | 3 | 17 | use constant query_rr_type_spf => 2; | |||
3 | 6 | ||||||
3 | 142 | ||||||
44 | |||||||
45 | 3 | 224 | use constant default_default_authority_explanation => | ||||
46 | 3 | 3 | 14 | 'Please see http://www.openspf.org/Why?s=%{_scope};id=%{S};ip=%{C};r=%{R}'; | |||
3 | 6 | ||||||
47 | |||||||
48 | 6 | 6 | 0 | 29 | sub default_query_rr_types { shift->query_rr_type_txt }; | ||
49 | |||||||
50 | 3 | 3 | 17 | use constant default_max_dns_interactive_terms => 10; # RFC 4408, 10.1/6 | |||
3 | 5 | ||||||
3 | 141 | ||||||
51 | 3 | 3 | 16 | use constant default_max_name_lookups_per_term => 10; # RFC 4408, 10.1/7 | |||
3 | 12 | ||||||
3 | 279 | ||||||
52 | 5 | 5 | 0 | 19 | sub default_max_name_lookups_per_mx_mech { shift->max_name_lookups_per_term }; | ||
53 | 6 | 6 | 0 | 51 | sub default_max_name_lookups_per_ptr_mech { shift->max_name_lookups_per_term }; | ||
54 | |||||||
55 | 3 | 3 | 18 | use constant default_max_void_dns_lookups => 2; | |||
3 | 6 | ||||||
3 | 10124 | ||||||
56 | |||||||
57 | # Interface: | ||||||
58 | ############################################################################## | ||||||
59 | |||||||
60 | =head1 SYNOPSIS | ||||||
61 | |||||||
62 | use Mail::SPF; | ||||||
63 | |||||||
64 | my $spf_server = Mail::SPF::Server->new( | ||||||
65 | # Optional custom default for authority explanation: | ||||||
66 | default_authority_explanation => | ||||||
67 | 'See http://www.%{d}/why/id=%{S};ip=%{I};r=%{R}' | ||||||
68 | ); | ||||||
69 | |||||||
70 | my $result = $spf_server->process($request); | ||||||
71 | |||||||
72 | =cut | ||||||
73 | |||||||
74 | # Implementation: | ||||||
75 | ############################################################################## | ||||||
76 | |||||||
77 | =head1 DESCRIPTION | ||||||
78 | |||||||
79 | B |
||||||
80 | server instance can be configured with specific processing parameters. Also, | ||||||
81 | the default I |
||||||
82 | be overridden with a custom resolver object. | ||||||
83 | |||||||
84 | =head2 Constructor | ||||||
85 | |||||||
86 | The following constructor is provided: | ||||||
87 | |||||||
88 | =over | ||||||
89 | |||||||
90 | =item B |
||||||
91 | |||||||
92 | Creates a new server object for processing SPF requests. | ||||||
93 | |||||||
94 | %options is a list of key/value pairs representing any of the following | ||||||
95 | options: | ||||||
96 | |||||||
97 | =over | ||||||
98 | |||||||
99 | =item B |
||||||
100 | |||||||
101 | A I |
||||||
102 | string to use if the authority domain does not specify an explanation string of | ||||||
103 | its own. Defaults to: | ||||||
104 | |||||||
105 | 'Please see http://www.openspf.org/Why?s=%{_scope};id=%{S};ip=%{C};r=%{R}' | ||||||
106 | |||||||
107 | As can be seen from the default, a non-standard C<_scope> pseudo macro is | ||||||
108 | supported that expands to the name of the identity's scope. (Note: Do I |
||||||
109 | use any non-standard macros in explanation strings published in DNS.) | ||||||
110 | |||||||
111 | =item B |
||||||
112 | |||||||
113 | A I |
||||||
114 | be used for expanding the C |
||||||
115 | system's configured host name. | ||||||
116 | |||||||
117 | =item B |
||||||
118 | |||||||
119 | An optional DNS resolver object. If none is specified, a new I |
||||||
120 | object is used. The resolver object may be of a different class, but it must | ||||||
121 | provide an interface similar to I |
||||||
122 | and C |
||||||
123 | return either an object of class I |
||||||
124 | error, B |
||||||
125 | |||||||
126 | =item B |
||||||
127 | |||||||
128 | For which RR types to query when looking up and selecting SPF records. The | ||||||
129 | following values are supported: | ||||||
130 | |||||||
131 | =over | ||||||
132 | |||||||
133 | =item B<< Mail::SPF::Server->query_rr_type_all >> | ||||||
134 | |||||||
135 | Both C |
||||||
136 | |||||||
137 | =item B<< Mail::SPF::Server->query_rr_type_txt >> (default) | ||||||
138 | |||||||
139 | C |
||||||
140 | |||||||
141 | =item B<< Mail::SPF::Server->query_rr_type_spf >> | ||||||
142 | |||||||
143 | C |
||||||
144 | |||||||
145 | =back | ||||||
146 | |||||||
147 | For years B |
||||||
148 | RRs as recommended by RFC 4408. Experience has shown, however, that a | ||||||
149 | significant portion of name servers suffer from serious brain damage with | ||||||
150 | regard to the handling of queries for RR types that are unknown to them, such | ||||||
151 | as the C |
||||||
152 | only C |
||||||
153 | option. | ||||||
154 | |||||||
155 | See RFC 4408, 3.1.1, for a discussion of the topic, as well as the description | ||||||
156 | of the L method. | ||||||
157 | |||||||
158 | =item B |
||||||
159 | |||||||
160 | An I |
||||||
161 | per SPF check that perform DNS look-ups, as defined in RFC 4408, 10.1, | ||||||
162 | paragraph 6. If B |
||||||
163 | terms. Defaults to B<10>, which is the value defined in RFC 4408. | ||||||
164 | |||||||
165 | A value above the default is I |
||||||
166 | value below the default has implications with regard to the predictability of | ||||||
167 | SPF results. Only deviate from the default if you know what you are doing! | ||||||
168 | |||||||
169 | =item B |
||||||
170 | |||||||
171 | An I |
||||||
172 | (mechanism or modifier), as defined in RFC 4408, 10.1, paragraph 7. If | ||||||
173 | B |
||||||
174 | Defaults to B<10>, which is the value defined in RFC 4408. | ||||||
175 | |||||||
176 | A value above the default is I |
||||||
177 | value below the default has implications with regard to the predictability of | ||||||
178 | SPF results. Only deviate from the default if you know what you are doing! | ||||||
179 | |||||||
180 | =item B |
||||||
181 | |||||||
182 | =item B |
||||||
183 | |||||||
184 | An I |
||||||
185 | mechanism, respectively. Defaults to the value of the C |
||||||
186 | option. See there for additional information and security notes. | ||||||
187 | |||||||
188 | =item B |
||||||
189 | |||||||
190 | An I |
||||||
191 | i.e. the number of DNS look-ups that were caused by DNS-interactive terms and | ||||||
192 | macros (as defined in RFC 4408, 10.1, paragraphs 6 and 7) and that are allowed | ||||||
193 | to return an empty answer with RCODE 0 or RCODE 3 (C |
||||||
194 | processing is aborted with a C |
||||||
195 | there is no stricter limit on the number of void DNS look-ups beyond the usual | ||||||
196 | processing limits. Defaults to B<2>. | ||||||
197 | |||||||
198 | Specifically, the DNS look-ups that are subject to this limit are those caused | ||||||
199 | by the C, C macro. |
||||||
200 | |||||||
201 | A value of B<2> is likely to prevent effective DoS attacks against third-party | ||||||
202 | victim domains. However, a definite limit may cause C |
||||||
203 | with certain (overly complex) innocent sender policies where useful results | ||||||
204 | would normally be returned. | ||||||
205 | |||||||
206 | =back | ||||||
207 | |||||||
208 | =cut | ||||||
209 | |||||||
210 | sub new { | ||||||
211 | 6 | 6 | 1 | 7876 | my ($self, %options) = @_; | ||
212 | 6 | 61 | $self = $self->SUPER::new(%options); | ||||
213 | |||||||
214 | 6 | 50 | 53 | $self->{default_authority_explanation} = $self->default_default_authority_explanation | |||
215 | if not defined($self->{default_authority_explanation}); | ||||||
216 | 6 | 50 | 76 | $self->{default_authority_explanation} = Mail::SPF::MacroString->new( | |||
217 | text => $self->{default_authority_explanation}, | ||||||
218 | server => $self, | ||||||
219 | is_explanation => TRUE | ||||||
220 | ) | ||||||
221 | if not UNIVERSAL::isa($self->{default_authority_explanation}, 'Mail::SPF::MacroString'); | ||||||
222 | |||||||
223 | 6 | 33 | 59 | $self->{hostname} ||= Mail::SPF::Util->hostname; | |||
224 | |||||||
225 | 6 | 66 | 1278 | $self->{dns_resolver} ||= Net::DNS::Resolver->new(); | |||
226 | |||||||
227 | 6 | 50 | 70 | $self->{query_rr_types} = $self->default_query_rr_types | |||
228 | if not defined($self->{query_rr_types}); | ||||||
229 | |||||||
230 | 6 | 100 | 28 | $self->{max_dns_interactive_terms} = $self->default_max_dns_interactive_terms | |||
231 | if not exists($self->{max_dns_interactive_terms}); | ||||||
232 | 6 | 100 | 27 | $self->{max_name_lookups_per_term} = $self->default_max_name_lookups_per_term | |||
233 | if not exists($self->{max_name_lookups_per_term}); | ||||||
234 | 6 | 100 | 32 | $self->{max_name_lookups_per_mx_mech} = $self->default_max_name_lookups_per_mx_mech | |||
235 | if not exists($self->{max_name_lookups_per_mx_mech}); | ||||||
236 | 6 | 50 | 37 | $self->{max_name_lookups_per_ptr_mech} = $self->default_max_name_lookups_per_ptr_mech | |||
237 | if not exists($self->{max_name_lookups_per_ptr_mech}); | ||||||
238 | |||||||
239 | 6 | 50 | 41 | $self->{max_void_dns_lookups} = $self->default_max_void_dns_lookups | |||
240 | if not exists($self->{max_void_dns_lookups}); | ||||||
241 | |||||||
242 | 6 | 47 | return $self; | ||||
243 | } | ||||||
244 | |||||||
245 | =back | ||||||
246 | |||||||
247 | =head2 Class methods | ||||||
248 | |||||||
249 | The following class methods are provided: | ||||||
250 | |||||||
251 | =over | ||||||
252 | |||||||
253 | =item B |
||||||
254 | |||||||
255 | =item B |
||||||
256 | |||||||
257 | Returns a I |
||||||
258 | result name via the server's inherent result base class, or returns the | ||||||
259 | server's inherent result base class if no result name is given. This method | ||||||
260 | may also be used as an instance method. | ||||||
261 | |||||||
262 | I |
||||||
263 | names as this would ignore any derivative result classes provided by | ||||||
264 | B |
||||||
265 | |||||||
266 | =cut | ||||||
267 | |||||||
268 | sub result_class { | ||||||
269 | 0 | 0 | 1 | 0 | my ($self, $name) = @_; | ||
270 | return | ||||||
271 | 0 | 0 | 0 | defined($name) ? | |||
272 | $self->result_base_class->result_classes->{$name} | ||||||
273 | : $self->result_base_class; | ||||||
274 | } | ||||||
275 | |||||||
276 | =item B |
||||||
277 | |||||||
278 | =item B |
||||||
279 | |||||||
280 | Throws a I |
||||||
281 | via the server's inherent result base class, passing an optional result text | ||||||
282 | and associating the given I |
||||||
283 | This method may also be used as an instance method. | ||||||
284 | |||||||
285 | I |
||||||
286 | as this would ignore any derivative result classes provided by B |
||||||
287 | extension modules. | ||||||
288 | |||||||
289 | =cut | ||||||
290 | |||||||
291 | sub throw_result { | ||||||
292 | 0 | 0 | 1 | 0 | my ($self, $name, $request, @text) = @_; | ||
293 | 0 | 0 | $self->result_class($name)->throw($self, $request, @text); | ||||
294 | } | ||||||
295 | |||||||
296 | =back | ||||||
297 | |||||||
298 | =head2 Instance methods | ||||||
299 | |||||||
300 | The following instance methods are provided: | ||||||
301 | |||||||
302 | =over | ||||||
303 | |||||||
304 | =item B |
||||||
305 | |||||||
306 | Processes the given I |
||||||
307 | domain for an SPF sender policy (see the description of the L | ||||||
308 | method), evaluates the policy with regard to the given identity and other | ||||||
309 | request parameters, and returns a I |
||||||
310 | result of the policy evaluation. See RFC 4408, 4, and RFC 4406, 4, for | ||||||
311 | details. | ||||||
312 | |||||||
313 | =cut | ||||||
314 | |||||||
315 | sub process { | ||||||
316 | 0 | 0 | 1 | 0 | my ($self, $request) = @_; | ||
317 | |||||||
318 | 0 | 0 | $request->state('authority_explanation', undef); | ||||
319 | 0 | 0 | $request->state('dns_interactive_terms_count', 0); | ||||
320 | 0 | 0 | $request->state('void_dns_lookups_count', 0); | ||||
321 | |||||||
322 | 0 | 0 | my $result; | ||||
323 | try { | ||||||
324 | 0 | 0 | 0 | my $record = $self->select_record($request); | |||
325 | 0 | 0 | $request->record($record); | ||||
326 | 0 | 0 | $record->eval($self, $request); | ||||
327 | } | ||||||
328 | catch Mail::SPF::Result with { | ||||||
329 | 0 | 0 | 0 | $result = shift; | |||
330 | } | ||||||
331 | catch Mail::SPF::EDNSError with { | ||||||
332 | 0 | 0 | 0 | $result = $self->result_class('temperror')->new($self, $request, shift->text); | |||
333 | } | ||||||
334 | catch Mail::SPF::ENoAcceptableRecord with { | ||||||
335 | 0 | 0 | 0 | $result = $self->result_class('none' )->new($self, $request, shift->text); | |||
336 | } | ||||||
337 | catch Mail::SPF::ERedundantAcceptableRecords with { | ||||||
338 | 0 | 0 | 0 | $result = $self->result_class('permerror')->new($self, $request, shift->text); | |||
339 | } | ||||||
340 | catch Mail::SPF::ESyntaxError with { | ||||||
341 | 0 | 0 | 0 | $result = $self->result_class('permerror')->new($self, $request, shift->text); | |||
342 | } | ||||||
343 | catch Mail::SPF::EProcessingLimitExceeded with { | ||||||
344 | 0 | 0 | 0 | $result = $self->result_class('permerror')->new($self, $request, shift->text); | |||
345 | 0 | 0 | }; | ||||
346 | # Propagate other, unknown errors. | ||||||
347 | # This should not happen, but if it does, it helps exposing the bug! | ||||||
348 | |||||||
349 | 0 | 0 | return $result; | ||||
350 | } | ||||||
351 | |||||||
352 | =item B |
||||||
353 | throws I |
||||||
354 | I |
||||||
355 | I |
||||||
356 | |||||||
357 | Queries the authority domain of the given I |
||||||
358 | sender policy records and, if multiple records are available, selects the | ||||||
359 | record of the highest acceptable record version that covers the requested | ||||||
360 | scope. | ||||||
361 | |||||||
362 | More precisely, the following algorithm is performed (assuming that both C |
||||||
363 | and C |
||||||
364 | |||||||
365 | =over | ||||||
366 | |||||||
367 | =item 1. | ||||||
368 | |||||||
369 | Determine the authority domain, the set of acceptable SPF record versions, and | ||||||
370 | the identity scope from the given request object. | ||||||
371 | |||||||
372 | =item 2. | ||||||
373 | |||||||
374 | Query the authority domain for SPF records of the C |
||||||
375 | discarding any records that are of an inacceptable version or do not cover the | ||||||
376 | desired scope. | ||||||
377 | |||||||
378 | If this yields no SPF records, query the authority domain for SPF records of | ||||||
379 | the C |
||||||
380 | version or do not cover the desired scope. | ||||||
381 | |||||||
382 | If still no acceptable SPF records could be found, throw a | ||||||
383 | I |
||||||
384 | |||||||
385 | =item 3. | ||||||
386 | |||||||
387 | Discard all records but those of the highest acceptable version found. | ||||||
388 | |||||||
389 | If exactly one record remains, return it. Otherwise, throw a | ||||||
390 | I |
||||||
391 | |||||||
392 | =back | ||||||
393 | |||||||
394 | If the querying of either RR type has been disabled via the L | ||||||
395 | constructor's C |
||||||
396 | be skipped. | ||||||
397 | |||||||
398 | I |
||||||
399 | I |
||||||
400 | also be thrown. | ||||||
401 | |||||||
402 | =cut | ||||||
403 | |||||||
404 | sub select_record { | ||||||
405 | 0 | 0 | 1 | 0 | my ($self, $request) = @_; | ||
406 | |||||||
407 | 0 | 0 | my $domain = $request->authority_domain; | ||||
408 | 0 | 0 | my @versions = $request->versions; | ||||
409 | 0 | 0 | my $scope = $request->scope; | ||||
410 | |||||||
411 | # Employ identical behavior for 'v=spf1' and 'spf2.0' records, both of | ||||||
412 | # which support SPF (code 99) and TXT type records (this may be different | ||||||
413 | # in future revisions of SPF): | ||||||
414 | # Query for SPF type records first, then fall back to TXT type records. | ||||||
415 | |||||||
416 | 0 | 0 | my @records; | ||||
417 | 0 | 0 | my $query_count = 0; | ||||
418 | 0 | 0 | my @dns_errors; | ||||
419 | |||||||
420 | # Query for SPF-type RRs first: | ||||||
421 | 0 | 0 | 0 | 0 | if ( | ||
422 | $self->query_rr_types == $self->query_rr_type_all or | ||||||
423 | $self->query_rr_types & $self->query_rr_type_spf | ||||||
424 | ) { | ||||||
425 | try { | ||||||
426 | 0 | 0 | 0 | $query_count++; | |||
427 | 0 | 0 | my $packet = $self->dns_lookup($domain, 'SPF'); | ||||
428 | 0 | 0 | push( | ||||
429 | @records, | ||||||
430 | $self->get_acceptable_records_from_packet( | ||||||
431 | $packet, 'SPF', \@versions, $scope, $domain) | ||||||
432 | ); | ||||||
433 | } | ||||||
434 | catch Mail::SPF::EDNSError with { | ||||||
435 | 0 | 0 | 0 | push(@dns_errors, shift); | |||
436 | 0 | 0 | }; | ||||
437 | #catch Mail::SPF::EDNSTimeout with { | ||||||
438 | # # FIXME Ignore DNS time-outs on SPF type lookups? | ||||||
439 | # # Apparrently some brain-dead DNS servers time out on SPF-type queries. | ||||||
440 | #}; | ||||||
441 | } | ||||||
442 | |||||||
443 | # If no usable SPF-type RRs, try TXT-type RRs: | ||||||
444 | 0 | 0 | 0 | 0 | if ( | ||
0 | |||||||
445 | not @records and | ||||||
446 | ( | ||||||
447 | $self->query_rr_types == $self->query_rr_type_all or | ||||||
448 | $self->query_rr_types & $self->query_rr_type_txt | ||||||
449 | ) | ||||||
450 | ) { | ||||||
451 | # NOTE: | ||||||
452 | # This deliberately violates RFC 4406 (Sender ID), 4.4/3 (4.4.1): | ||||||
453 | # TXT-type RRs are still tried if there _are_ SPF-type RRs but all of | ||||||
454 | # them are inapplicable (i.e. "Hi!", or even "spf2.0/pra" for an | ||||||
455 | # 'mfrom' scope request). This conforms to the spirit of the more | ||||||
456 | # sensible algorithm in RFC 4408 (SPF), 4.5. | ||||||
457 | # Implication: Sender ID processing may make use of existing TXT- | ||||||
458 | # type records where a result of "None" would normally be returned | ||||||
459 | # under a strict interpretation of RFC 4406. | ||||||
460 | |||||||
461 | try { | ||||||
462 | 0 | 0 | 0 | $query_count++; | |||
463 | 0 | 0 | my $packet = $self->dns_lookup($domain, 'TXT'); | ||||
464 | 0 | 0 | push( | ||||
465 | @records, | ||||||
466 | $self->get_acceptable_records_from_packet( | ||||||
467 | $packet, 'TXT', \@versions, $scope, $domain) | ||||||
468 | ); | ||||||
469 | } | ||||||
470 | catch Mail::SPF::EDNSError with { | ||||||
471 | 0 | 0 | 0 | push(@dns_errors, shift); | |||
472 | 0 | 0 | }; | ||||
473 | } | ||||||
474 | |||||||
475 | 0 | 0 | 0 | @dns_errors < $query_count | |||
476 | or $dns_errors[0]->throw; | ||||||
477 | # Unless at least one query succeeded, re-throw the first DNS error that occurred. | ||||||
478 | |||||||
479 | @records | ||||||
480 | 0 | 0 | 0 | or throw Mail::SPF::ENoAcceptableRecord( | |||
481 | "No applicable sender policy available"); # RFC 4408, 4.5/7 | ||||||
482 | |||||||
483 | # Discard all records but the highest acceptable version: | ||||||
484 | 0 | 0 | my $preferred_record_class = $records[0]->class; | ||||
485 | 0 | 0 | @records = grep($_->isa($preferred_record_class), @records); | ||||
486 | |||||||
487 | 0 | 0 | 0 | @records == 1 | |||
488 | or throw Mail::SPF::ERedundantAcceptableRecords( | ||||||
489 | "Redundant applicable '" . $preferred_record_class->version_tag . "' " . | ||||||
490 | "sender policies found"); # RFC 4408, 4.5/6 | ||||||
491 | |||||||
492 | 0 | 0 | return $records[0]; | ||||
493 | } | ||||||
494 | |||||||
495 | =item B |
||||||
496 | returns I
|
||||||
497 | |||||||
498 | Filters from the given I |
||||||
499 | given RR type and for the given domain name, discarding any records that are | ||||||
500 | not SPF records at all, that are of an inacceptable SPF record version, or that | ||||||
501 | do not cover the given scope. Returns a list of acceptable records. | ||||||
502 | |||||||
503 | =cut | ||||||
504 | |||||||
505 | sub get_acceptable_records_from_packet { | ||||||
506 | 0 | 0 | 1 | 0 | my ($self, $packet, $rr_type, $versions, $scope, $domain) = @_; | ||
507 | |||||||
508 | 0 | 0 | my @versions = sort { $b <=> $a } @$versions; | ||||
0 | 0 | ||||||
509 | # Try higher record versions first. | ||||||
510 | # (This may be too simplistic for future revisions of SPF.) | ||||||
511 | |||||||
512 | 0 | 0 | my @records; | ||||
513 | 0 | 0 | foreach my $rr ($packet->answer) { | ||||
514 | 0 | 0 | 0 | next if $rr->type ne $rr_type; # Ignore RRs of unexpected type. | |||
515 | |||||||
516 | 0 | 0 | my $text = join('', $rr->char_str_list); | ||||
517 | 0 | 0 | my $record; | ||||
518 | |||||||
519 | # Try to parse RR as each of the requested record versions, | ||||||
520 | # starting from the highest version: | ||||||
521 | VERSION: | ||||||
522 | 0 | 0 | foreach my $version (@versions) { | ||||
523 | 0 | 0 | my $class = $self->record_classes_by_version->{$version}; | ||||
524 | 0 | 0 | eval("require $class"); | ||||
525 | try { | ||||||
526 | 0 | 0 | 0 | $record = $class->new_from_string($text); | |||
527 | } | ||||||
528 | 0 | 0 | 0 | catch Mail::SPF::EInvalidRecordVersion with {}; | |||
0 | 0 | ||||||
529 | # Ignore non-SPF and unknown-version records. | ||||||
530 | # Propagate other errors (including syntax errors), though. | ||||||
531 | 0 | 0 | 0 | last VERSION if defined($record); | |||
532 | } | ||||||
533 | |||||||
534 | 0 | 0 | 0 | 0 | push(@records, $record) | ||
535 | if defined($record) | ||||||
536 | and grep($scope eq $_, $record->scopes); # record covers requested scope? | ||||||
537 | } | ||||||
538 | 0 | 0 | return @records; | ||||
539 | } | ||||||
540 | |||||||
541 | =item B |
||||||
542 | throws I |
||||||
543 | |||||||
544 | Queries the DNS using the configured resolver for resource records of the | ||||||
545 | desired type at the specified domain and returns a I |
||||||
546 | if an answer packet was received. Throws a I |
||||||
547 | if a DNS time-out occurred. Throws a I |
||||||
548 | error (other than RCODE 3 AKA C |
||||||
549 | |||||||
550 | =cut | ||||||
551 | |||||||
552 | sub dns_lookup { | ||||||
553 | 3 | 3 | 1 | 17 | my ($self, $domain, $rr_type) = @_; | ||
554 | |||||||
555 | 3 | 50 | 16 | if (UNIVERSAL::isa($domain, 'Mail::SPF::MacroString')) { | |||
556 | 0 | 0 | $domain = $domain->expand; | ||||
557 | # Truncate overlong labels at 63 bytes (RFC 4408, 8.1/27): | ||||||
558 | 0 | 0 | $domain =~ s/([^.]{63})[^.]+/$1/g; | ||||
559 | # Drop labels from the head of domain if longer than 253 bytes (RFC 4408, 8.1/25): | ||||||
560 | 0 | 0 | $domain =~ s/^[^.]+\.(.*)$/$1/ | ||||
561 | while length($domain) > 253; | ||||||
562 | } | ||||||
563 | |||||||
564 | 3 | 29 | $domain =~ s/^(.*?)\.?$/\L$1/; # Normalize domain. | ||||
565 | |||||||
566 | 3 | 9 | my $packet = $self->dns_resolver->send($domain, $rr_type); | ||||
567 | |||||||
568 | # Throw DNS exception unless an answer packet with RCODE 0 or 3 (NXDOMAIN) | ||||||
569 | # was received (thereby treating NXDOMAIN as an acceptable but empty answer packet): | ||||||
570 | 3 | 50 | 6142 | $self->dns_resolver->errorstring !~ /^(timeout|query timed out)$/ | |||
571 | or throw Mail::SPF::EDNSTimeout( | ||||||
572 | "Time-out on DNS '$rr_type' lookup of '$domain'"); | ||||||
573 | 3 | 100 | 61 | defined($packet) | |||
574 | or throw Mail::SPF::EDNSError( | ||||||
575 | "Unknown error on DNS '$rr_type' lookup of '$domain'"); | ||||||
576 | 2 | 50 | 10 | $packet->header->rcode =~ /^(NOERROR|NXDOMAIN)$/ | |||
577 | or throw Mail::SPF::EDNSError( | ||||||
578 | "'" . $packet->header->rcode . "' error on DNS '$rr_type' lookup of '$domain'"); | ||||||
579 | |||||||
580 | 2 | 93 | return $packet; | ||||
581 | } | ||||||
582 | |||||||
583 | =item B |
||||||
584 | |||||||
585 | Increments by one the count of DNS-interactive mechanisms and modifiers that | ||||||
586 | have been processed so far during the evaluation of the given | ||||||
587 | I |
||||||
588 | L constructor's C |
||||||
589 | I |
||||||
590 | |||||||
591 | This method is supposed to be called by the C |
||||||
592 | I |
||||||
593 | do any DNS look-ups. | ||||||
594 | |||||||
595 | =cut | ||||||
596 | |||||||
597 | sub count_dns_interactive_term { | ||||||
598 | 0 | 0 | 1 | my ($self, $request) = @_; | |||
599 | 0 | my $dns_interactive_terms_count = ++$request->root_request->state('dns_interactive_terms_count'); | |||||
600 | 0 | my $max_dns_interactive_terms = $self->max_dns_interactive_terms; | |||||
601 | 0 | 0 | 0 | if ( | |||
602 | defined($max_dns_interactive_terms) and | ||||||
603 | $dns_interactive_terms_count > $max_dns_interactive_terms | ||||||
604 | ) { | ||||||
605 | 0 | throw Mail::SPF::EProcessingLimitExceeded( | |||||
606 | "Maximum DNS-interactive terms limit ($max_dns_interactive_terms) exceeded"); | ||||||
607 | } | ||||||
608 | 0 | return; | |||||
609 | } | ||||||
610 | |||||||
611 | =item B |
||||||
612 | |||||||
613 | Increments by one the count of "void" DNS look-ups that have occurred so far | ||||||
614 | during the evaluation of the given I |
||||||
615 | exceeds the configured limit (see the L constructor's C |
||||||
616 | option), throws a I |
||||||
617 | |||||||
618 | This method is supposed to be called by any code after any calls to the | ||||||
619 | L method whenever (i) no answer records were returned, and (ii) | ||||||
620 | this fact is a possible indication of a DoS attack against a third-party victim | ||||||
621 | domain, and (iii) the number of "void" look-ups is not already constrained | ||||||
622 | otherwise (as for example is the case with the C |
||||||
623 | C |
||||||
624 | C, C macro. |
||||||
625 | |||||||
626 | =cut | ||||||
627 | |||||||
628 | sub count_void_dns_lookup { | ||||||
629 | 0 | 0 | 1 | my ($self, $request) = @_; | |||
630 | 0 | my $void_dns_lookups_count = ++$request->root_request->state('void_dns_lookups_count'); | |||||
631 | 0 | my $max_void_dns_lookups = $self->max_void_dns_lookups; | |||||
632 | 0 | 0 | 0 | if ( | |||
633 | defined($max_void_dns_lookups) and | ||||||
634 | $void_dns_lookups_count > $max_void_dns_lookups | ||||||
635 | ) { | ||||||
636 | 0 | throw Mail::SPF::EProcessingLimitExceeded( | |||||
637 | "Maximum void DNS look-ups limit ($max_void_dns_lookups) exceeded"); | ||||||
638 | } | ||||||
639 | 0 | return; | |||||
640 | } | ||||||
641 | |||||||
642 | =item B |
||||||
643 | |||||||
644 | Returns the default authority explanation as a I |
||||||
645 | description of the L constructor's C |
||||||
646 | option. | ||||||
647 | |||||||
648 | =item B |
||||||
649 | |||||||
650 | Returns the local system's host name. See the description of the L | ||||||
651 | constructor's C |
||||||
652 | |||||||
653 | =item B |
||||||
654 | |||||||
655 | Returns the DNS resolver object of the server object. See the description of | ||||||
656 | the L constructor's C |
||||||
657 | |||||||
658 | =item B |
||||||
659 | |||||||
660 | Returns a value denoting the RR types for which to query when looking up and | ||||||
661 | selecting SPF records. See the description of the L constructor's | ||||||
662 | C |
||||||
663 | |||||||
664 | =item B |
||||||
665 | |||||||
666 | =item B |
||||||
667 | |||||||
668 | =item B |
||||||
669 | |||||||
670 | =item B |
||||||
671 | |||||||
672 | =item B |
||||||
673 | |||||||
674 | Return the limit values of the server object. See the description of the | ||||||
675 | L constructor's corresponding options. | ||||||
676 | |||||||
677 | =cut | ||||||
678 | |||||||
679 | # Make read-only accessors: | ||||||
680 | __PACKAGE__->make_accessor($_, TRUE) | ||||||
681 | foreach qw( | ||||||
682 | default_authority_explanation | ||||||
683 | hostname | ||||||
684 | |||||||
685 | dns_resolver | ||||||
686 | query_rr_types | ||||||
687 | |||||||
688 | max_dns_interactive_terms | ||||||
689 | max_name_lookups_per_term | ||||||
690 | max_name_lookups_per_mx_mech | ||||||
691 | max_name_lookups_per_ptr_mech | ||||||
692 | |||||||
693 | max_void_dns_lookups | ||||||
694 | ); | ||||||
695 | |||||||
696 | =back | ||||||
697 | |||||||
698 | =head1 SEE ALSO | ||||||
699 | |||||||
700 | L |
||||||
701 | |||||||
702 | L |
||||||
703 | |||||||
704 | For availability, support, and license information, see the README file | ||||||
705 | included with Mail::SPF. | ||||||
706 | |||||||
707 | =head1 AUTHORS | ||||||
708 | |||||||
709 | Julian Mehnle |
||||||
710 | |||||||
711 | =cut | ||||||
712 | |||||||
713 | TRUE; |