#!/usr/bin/perl

# Copyright 2005-2007 Messiah College.
# Jason Long <jlong@messiah.edu>

# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use strict;
use warnings;

package Mail::DKIM::Policy;

use Mail::DKIM::DNS;

=head1 NAME

Mail::DKIM::Policy - abstract base class for originator "signing" policies

=head1 SYNOPSIS

  # get all policies that apply to a verified message
  foreach my $policy ($dkim->policies)
  {

      # the name of this policy
      my $name = $policy->name;

      # the location in DNS where this policy was found
      my $location = $policy->location;

      # apply this policy to the message being verified
      my $result = $policy->apply($dkim);

  }

=head1 DESCRIPTION

Between the various versions of the DomainKeys/DKIM standards, several
different forms of sender "signing" policies have been defined.
In order for the L<Mail::DKIM> library to support these different
policies, it uses several different subclasses. All subclasses support
this general interface, so that a program using L<Mail::DKIM> can
support any and all policies found for a message.

=cut

sub fetch {
    my $class  = shift;
    my $waiter = $class->fetch_async(@_);
    return $waiter->();
}

sub fetch_async {
    my $class = shift;
    my %prms  = @_;

    ( $prms{'Protocol'} eq 'dns' )
      or die "invalid protocol '$prms{Protocol}'\n";

    my $host       = $class->get_lookup_name( \%prms );
    my %callbacks  = %{ $prms{Callbacks} || {} };
    my $on_success = $callbacks{Success} || sub { $_[0] };
    $callbacks{Success} = sub {
        my @resp = @_;
        unless (@resp) {

            # no requested resource records or NXDOMAIN,
            # use default policy
            return $on_success->( $class->default );
        }

        my $strn;
        foreach my $rr (@resp) {
            next unless $rr->type eq 'TXT';

            # join with no intervening spaces, RFC 5617
            if ( Net::DNS->VERSION >= 0.69 ) {

                # must call txtdata() in a list context
                $strn = join '', $rr->txtdata;
            }
            else {
                # char_str_list method is 'historical'
                $strn = join '', $rr->char_str_list;
            }
        }

        unless ($strn) {

            # empty record found in DNS, use default policy
            return $on_success->( $class->default );
        }

        my $self = $class->parse(
            String => $strn,
            Domain => $prms{Domain},
        );
        return $on_success->($self);
    };

    #
    # perform DNS query for domain policy...
    #
    my $waiter =
      Mail::DKIM::DNS::query_async( $host, 'TXT', Callbacks => \%callbacks, );
    return $waiter;
}

sub parse {
    my $class = shift;
    my %prms  = @_;

    my $text = $prms{'String'};
    my %tags;
    foreach my $tag ( split /;/, $text ) {

        # strip whitespace
        $tag =~ s/^\s+|\s+$//g;

        my ( $tagname, $value ) = split /=/, $tag, 2;
        unless ( defined $value ) {
            die "policy syntax error\n";
        }

        $tagname =~ s/\s+$//;
        $value =~ s/^\s+//;
        $tags{$tagname} = $value;
    }

    $prms{tags} = \%tags;
    return bless \%prms, $class;
}

=head1 METHODS

These methods are supported by all classes implementing the
L<Mail::DKIM::Policy> interface.

=head2 apply()

Apply the policy to the results of a DKIM verifier.

  my $result = $policy->apply($dkim_verifier);

The caller must provide an instance of L<Mail::DKIM::Verifier>, one which
has already been fed the message being verified.

Possible results are:

=over

=item accept

The message is approved by the sender signing policy.

=item reject

The message is rejected by the sender signing policy.

=item neutral

The message is neither approved nor rejected by the sender signing
policy. It can be considered suspicious.

=back

=cut

sub apply {
    my $self = shift;
    my ($dkim) = @_;

    my $first_party;
    foreach my $signature ( $dkim->signatures ) {
        next if $signature->result ne 'pass';

        my $oa = $dkim->message_sender->address;
        if ( $signature->identity_matches($oa) ) {

            # found a first party signature
            $first_party = 1;
            last;
        }
    }

    return 'accept' if $first_party;
    return 'reject' if ( $self->signall && !$self->testing );
    return 'neutral';
}

=head2 as_string()

The policy as a string.

Note that the string returned by this method will not necessarily have
the tags ordered the same as the text record found in DNS.

=cut

sub as_string {
    my $self = shift;

    return join(
        '; ', map { "$_=" . $self->{tags}->{$_} }
          keys %{ $self->{tags} }
    );
}

=head2 is_implied_default_policy()

Is this policy implied?

  my $is_implied = $policy->is_implied_default_policy;

If you fetch the policy for a particular domain, but that domain
does not have a policy published, then the "default policy" is
in effect. Use this method to detect when that happens.

=cut

sub is_implied_default_policy {
    my $self           = shift;
    my $default_policy = ref($self)->default;
    return ( $self == $default_policy );
}

=head2 location()

Where the policy was fetched from.

This is generally a domain name, the domain name where the policy
was published.

If nothing is published for the domain, and the default policy
was returned instead, the location will be C<undef>.

=cut

sub location {
    my $self = shift;
    return $self->{Domain};
}

=head2 name()

Identify what type of policy this is.

This currently returns strings like "sender", "author", and "ADSP".
It is subject to change in the next version of Mail::DKIM.

=cut

1;

=head1 SEE ALSO

L<Mail::DKIM::DkPolicy> - for RFC4870(historical) DomainKeys
sender signing policies

L<Mail::DKIM::DkimPolicy> - for early draft DKIM sender signing policies

L<Mail::DKIM::AuthorDomainPolicy> - for Author Domain Signing Practices
(ADSP)

=head1 AUTHOR

Jason Long, E<lt>jlong@messiah.eduE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006-2009 by Messiah College

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

=cut