1#
2# Mail::SPF::Mech
3# SPF record mechanism class.
4#
5# (C) 2005-2012 Julian Mehnle <julian@mehnle.net>
6#     2005      Shevek <cpan@anarres.org>
7# $Id: Mech.pm 57 2012-01-30 08:15:31Z julian $
8#
9##############################################################################
10
11package Mail::SPF::Mech;
12
13=head1 NAME
14
15Mail::SPF::Mech - SPF record mechanism base class
16
17=cut
18
19use warnings;
20use strict;
21
22use utf8;  # Hack to keep Perl 5.6 from whining about /[\p{}]/.
23
24use base 'Mail::SPF::Term';
25
26use Error ':try';
27use NetAddr::IP;
28
29use Mail::SPF::Record;
30use Mail::SPF::MacroString;
31use Mail::SPF::Util;
32
33use constant TRUE   => (0 == 0);
34use constant FALSE  => not TRUE;
35
36use constant default_qualifier          => Mail::SPF::Record->default_qualifier;
37use constant default_ipv4_prefix_length => 32;
38use constant default_ipv6_prefix_length => 128;
39
40use constant qualifier_pattern  => qr/[+\-~?]/;
41use constant name_pattern       => qr/ ${\__PACKAGE__->SUPER::name_pattern} (?= [:\/\x20] | $ ) /x;
42
43use constant explanation_templates_by_result_code => {
44    pass        => "Sender is authorized to use '%{s}' in '%{_scope}' identity",
45    fail        => "Sender is not authorized to use '%{s}' in '%{_scope}' identity",
46    softfail    => "Sender is not authorized to use '%{s}' in '%{_scope}' identity, however domain is not currently prepared for false failures",
47    neutral     => "Domain does not state whether sender is authorized to use '%{s}' in '%{_scope}' identity"
48};
49
50=head1 DESCRIPTION
51
52An object of class B<Mail::SPF::Mech> represents a mechanism within an SPF
53record.  Mail::SPF::Mech cannot be instantiated directly.  Create an instance
54of a concrete sub-class instead.
55
56=head2 Constructors
57
58The following constructors are provided:
59
60=over
61
62=item B<new(%options)>: returns I<Mail::SPF::Mech>
63
64I<Abstract>.  Creates a new SPF record mechanism object.
65
66%options is a list of key/value pairs representing any of the following
67options:
68
69=over
70
71=item B<text>
72
73A I<string> denoting the unparsed text of the mechanism.
74
75=item B<qualifier>
76
77A single-character I<string> denoting the qualifier of the mechanism.  Any of
78the following may be specified: B<'+'> (C<Pass>), B<'-'> (C<Fail>),
79B<'~'> (C<SoftFail>), B<'?'> (C<Neutral>).  See RFC 4408, 4.6.2 and 2.5, for
80their meanings.  Defaults to B<'+'>.
81
82=item B<name>
83
84A I<string> denoting the name of the mechanism.  I<Required> if a generic
85I<Mail::SPF::Mech> object (as opposed to a specific sub-class) is being
86constructed.
87
88=item B<ip_network>
89
90A I<NetAddr::IP> object denoting an optional IP address network parameter of
91the mechanism.  Can be either an IPv4 or an IPv6 address, with an optional
92network prefix length.  IPv4-mapped IPv6 addresses (e.g. '::ffff:192.168.0.1')
93must I<not> be specified directly, but as plain IPv4 addresses.
94
95=item B<domain_spec>
96
97Either a plain I<string> or a I<Mail::SPF::MacroString> object denoting an
98optional C<domain-spec> parameter of the mechanism.
99
100=item B<ipv4_prefix_length>
101
102=item B<ipv6_prefix_length>
103
104A I<string> denoting an optional IPv4 or IPv6 network prefix length for the
105C<domain_spec> of the mechanism.  Note that these options do not apply to the
106C<ip_network> option, which already includes an optional network prefix
107length.
108
109=back
110
111Other options may be specified by sub-classes of Mail::SPF::Mech.
112
113=cut
114
115sub new {
116    my ($self, %options) = @_;
117    $self->class ne __PACKAGE__
118        or throw Mail::SPF::EAbstractClass;
119    $self = $self->SUPER::new(%options);
120    $self->{parse_text} = $self->{text} if not defined($self->{parse_text});
121    $self->{domain_spec} = Mail::SPF::MacroString->new(text => $self->{domain_spec})
122        if  defined($self->{domain_spec})
123        and not UNIVERSAL::isa($self->{domain_spec}, 'Mail::SPF::MacroString');
124    return $self;
125}
126
127=item B<new_from_string($text, %options)>: returns I<Mail::SPF::Mech>;
128throws I<Mail::SPF::ENothingToParse>, I<Mail::SPF::EInvalidMech>
129
130I<Abstract>.  Creates a new SPF record mechanism object by parsing the string and
131any options given.
132
133=back
134
135=head2 Class methods
136
137The following class methods are provided:
138
139=over
140
141=item B<default_qualifier>: returns I<string>
142
143Returns the default qualifier, i.e. B<'+'>.
144
145=item B<default_ipv4_prefix_length>: returns I<integer>
146
147Returns the default IPv4 network prefix length, i.e. B<32>.
148
149=item B<default_ipv6_prefix_length>: returns I<integer>
150
151Returns the default IPv6 network prefix length, i.e. B<128>.
152
153=item B<qualifier_pattern>: returns I<Regexp>
154
155Returns a regular expression that matches any legal mechanism qualifier, i.e. B<'+'>,
156B<'-'>, B<'~'>, or B<'?'>.
157
158=item B<name>: returns I<string>
159
160I<Abstract>.  Returns the name of the mechanism.
161
162This method is abstract and must be implemented by sub-classes of
163Mail::SPF::Mech.
164
165=item B<name_pattern>: returns I<Regexp>
166
167Returns a regular expression that matches any legal mechanism name.
168
169=back
170
171=head2 Instance methods
172
173The following instance methods are provided:
174
175=over
176
177=cut
178
179sub parse {
180    my ($self) = @_;
181    defined($self->{parse_text})
182        or throw Mail::SPF::ENothingToParse('Nothing to parse for mechanism');
183    $self->parse_qualifier();
184    $self->parse_name();
185    $self->parse_params();
186    $self->parse_end();
187    return;
188}
189
190sub parse_qualifier {
191    my ($self) = @_;
192    if ($self->{parse_text} =~ s/^(${\$self->qualifier_pattern})?//) {
193        $self->{qualifier} = $1 || $self->default_qualifier;
194    }
195    else {
196        throw Mail::SPF::EInvalidMechQualifier(
197            "Invalid qualifier encountered in '" . $self->text . "'");
198    }
199    return;
200}
201
202sub parse_name {
203    my ($self) = @_;
204    if ($self->{parse_text} =~ s/^ (${\$self->name_pattern}) (?: : (?=.) )? //x) {
205        $self->{name} = $1;
206    }
207    else {
208        throw Mail::SPF::EInvalidMech(
209            "Unexpected mechanism name encountered in '" . $self->text . "'");
210    }
211    return;
212}
213
214sub parse_params {
215    my ($self) = @_;
216    # Parse generic string of parameters text (should be overridden in sub-classes):
217    if ($self->{parse_text} =~ s/^(.*)//) {
218        $self->{params_text} = $1;
219    }
220    return;
221}
222
223sub parse_end {
224    my ($self) = @_;
225    $self->{parse_text} eq ''
226        or throw Mail::SPF::EJunkInTerm("Junk encountered in mechanism '" . $self->text . "'");
227    delete($self->{parse_text});
228    return;
229}
230
231=item B<text>: returns I<string>; throws I<Mail::SPF::ENoUnparsedText>
232
233Returns the unparsed text of the mechanism.  Throws a
234I<Mail::SPF::ENoUnparsedText> exception if the mechanism was created
235synthetically instead of being parsed, and no text was provided.
236
237=item B<qualifier>: returns I<string>
238
239Returns the qualifier of the mechanism.  See the description of the C<new>
240constructor's C<qualifier> option.
241
242=cut
243
244sub qualifier {
245    my ($self) = @_;
246    # Read-only!
247    return $self->{qualifier} || $self->default_qualifier;
248}
249
250=item B<params>: returns I<string>
251
252I<Abstract>.  Returns the mechanism's parameters formatted as a string.
253
254A sub-class of Mail::SPF::Mech does not have to implement this method if it
255supports no parameters.
256
257=item B<stringify>: returns I<string>
258
259Formats the mechanism's qualifier, name, and parameters as a string and returns
260it.  (A qualifier that matches the default of B<'+'> is omitted.)  You can
261simply use a Mail::SPF::Mech object as a string for the same effect, see
262L<"OVERLOADING">.
263
264=cut
265
266sub stringify {
267    my ($self) = @_;
268    my $params = $self->can('params') ? $self->params : undef;
269    return sprintf(
270        '%s%s%s',
271        $self->qualifier eq $self->default_qualifier ? '' : $self->qualifier,
272        $self->name,
273        defined($params) ? $params : ''
274    );
275}
276
277=item B<domain($server, $request)>: returns I<string>
278
279Returns the target domain of the mechanism.  Depending on whether the mechanism
280does have an explicit C<domain_spec> parameter, this is either the
281macro-expanded C<domain_spec> parameter, or the request's authority domain
282(see L<Mail::SPF::Request/authority_domain>) otherwise.  Both a
283I<Mail::SPF::Server> and a I<Mail::SPF::Request> object are required for
284resolving the target domain.
285
286=cut
287
288sub domain {
289    my ($self, $server, $request) = @_;
290    defined($server)
291        or throw Mail::SPF::EOptionRequired('Mail::SPF server object required for target domain resolution');
292    defined($request)
293        or throw Mail::SPF::EOptionRequired('Request object required for target domain resolution');
294    return $self->{domain_spec}->new(server => $server, request => $request)
295        if defined($self->{domain_spec});
296    return $request->authority_domain;
297}
298
299=item B<match($server, $request)>: returns I<boolean>; throws I<Mail::SPF::Result::Error>
300
301I<Abstract>.  Checks whether the mechanism matches the parameters of the given
302request (see L<Mail::SPF::Request>) and returns B<true> if it does, or B<false>
303otherwise.  In any case, takes both a I<Mail::SPF::Server> and a
304I<Mail::SPF::Request> object.
305
306This method is abstract and must be implemented by sub-classes of
307Mail::SPF::Mech.
308
309=item B<match_in_domain($server, $request)>: returns I<boolean>;
310throws I<Mail::SPF::Result::Error>
311
312=item B<match_in_domain($server, $request, $domain)>: returns I<boolean>;
313throws I<Mail::SPF::Result::Error>
314
315Checks whether the mechanism's target domain name (that is, any of its DNS C<A>
316or C<AAAA> records) matches the given request's IP address (see
317L<Mail::SPF::Request/ip_address>), and returns B<true> if it does, or B<false>
318otherwise.  If an explicit domain is specified, it is used instead of the
319mechanism's target domain.  The mechanism's IP network prefix lengths are
320respected when matching DNS address records against the request's IP address.
321See RFC 4408, 5, for the exact algorithm used.
322
323This method exists mainly for the convenience of sub-classes of
324Mail::SPF::Mech.
325
326=cut
327
328sub match_in_domain {
329    my ($self, $server, $request, $domain) = @_;
330
331    $domain = $self->domain($server, $request)
332        if not defined($domain);
333
334    my $ipv4_prefix_length = $self->ipv4_prefix_length;
335    my $ipv6_prefix_length = $self->ipv6_prefix_length;
336    my $addr_rr_type       = $request->ip_address->version == 4 ? 'A' : 'AAAA';
337
338    my $packet             = $server->dns_lookup($domain, $addr_rr_type);
339    my @rrs                = $packet->answer
340        or $server->count_void_dns_lookup($request);
341
342    foreach my $rr (@rrs) {
343        if ($rr->type eq 'A') {
344            my $network = NetAddr::IP->new($rr->address, $ipv4_prefix_length);
345            return TRUE
346                if $network->contains($request->ip_address);
347        }
348        elsif ($rr->type eq 'AAAA') {
349            my $network = NetAddr::IP->new($rr->address, $ipv6_prefix_length);
350            return TRUE
351                if $network->contains($request->ip_address_v6);
352        }
353        elsif ($rr->type eq 'CNAME') {
354            # Ignore -- we should have gotten the A/AAAA records anyway.
355        }
356        else {
357            # Unexpected RR type.
358            # TODO Generate debug info or ignore silently.
359        }
360    }
361    return FALSE;
362}
363
364=item B<explain($server, $request, $result)>
365
366Locally generates an explanation for why the mechanism caused the given result,
367and stores it in the given request object's state.
368
369There is no need to override this method in sub-classes.  See the
370L</explanation_template> method.
371
372=cut
373
374sub explain {
375    my ($self, $server, $request, $result) = @_;
376    my $explanation_template = $self->explanation_template($server, $request, $result);
377    return
378        if not defined($explanation_template);
379    try {
380        my $explanation = Mail::SPF::MacroString->new(
381            text            => $explanation_template,
382            server          => $server,
383            request         => $request,
384            is_explanation  => TRUE
385        );
386        $request->state('local_explanation', $explanation);
387    }
388    catch Mail::SPF::Exception with {}
389    catch Mail::SPF::Result with {};
390    return;
391}
392
393=item B<explanation_template($server, $request, $result)>: returns I<string>
394
395Returns a macro string template for a locally generated explanation for why the
396mechanism caused the given result object.
397
398Sub-classes should either define an C<explanation_templates_by_result_code>
399hash constant with their own templates, or override this method.
400
401=cut
402
403sub explanation_template {
404    my ($self, $server, $request, $result) = @_;
405    return undef
406        if not $self->can('explanation_templates_by_result_code');
407    return $self->explanation_templates_by_result_code->{$result->code};
408}
409
410=back
411
412=head1 OVERLOADING
413
414If a Mail::SPF::Mech object is used as a I<string>, the C<stringify> method is
415used to convert the object into a string.
416
417=head1 SEE ALSO
418
419L<Mail::SPF::Mech::All>,
420L<Mail::SPF::Mech::IP4>,
421L<Mail::SPF::Mech::IP6>,
422L<Mail::SPF::Mech::A>,
423L<Mail::SPF::Mech::MX>,
424L<Mail::SPF::Mech::PTR>,
425L<Mail::SPF::Mech::Exists>,
426L<Mail::SPF::Mech::Include>
427
428L<Mail::SPF>, L<Mail::SPF::Record>, L<Mail::SPF::Term>
429
430L<http://tools.ietf.org/html/rfc4408>
431
432For availability, support, and license information, see the README file
433included with Mail::SPF.
434
435=head1 AUTHORS
436
437Julian Mehnle <julian@mehnle.net>, Shevek <cpan@anarres.org>
438
439=cut
440
441TRUE;
442