Mail::DKIM::Verifier - verifies a DKIM-signed message

  use Mail::DKIM::Verifier;

  # create a verifier object
  my $dkim = Mail::DKIM::Verifier->new();

  # read an email from a file handle
  $dkim->load(*STDIN);

  # or read an email and pass it into the verifier, incrementally
  while (<STDIN>)
  {
      # remove local line terminators
      chomp;
      s/\015$//;

      # use SMTP line terminators
      $dkim->PRINT("$_\015\012");
  }
  $dkim->CLOSE;

  # what is the result of the verify?
  my $result = $dkim->result;

  # there might be multiple signatures, what is the result per signature?
  foreach my $signature ($dkim->signatures)
  {
      print "signature identity: " . $signature->identity . "\n";
      print "verify result: " . $signature->result_detail . "\n";
  }

  # the alleged author of the email may specify how to handle email
  foreach my $policy ($dkim->policies)
  {
      die "fraudulent message" if ($policy->apply($dkim) eq "reject");
  }

 1. checks whether any DomainKeys/DKIM signatures were found
 2. queries for the public keys needed to verify the signatures
 3. sets up the appropriate algorithms and canonicalization objects
 4. canonicalizes the headers and computes the header hash

  my $dkim = Mail::DKIM::Verifier->new();

  my $dkim = Mail::DKIM::Verifier->new(%options);

  $dkim->PRINT("a line of the message\015\012");
  $dkim->PRINT("more of");
  $dkim->PRINT(" the message\015\012bye\015\012");

  $dkim->CLOSE;

  my @policies = $dkim->fetch_author_domain_policies;
  foreach my $policy (@policies)
  {
      my $policy_result = $policy->apply($dkim);
  }

  my $policy = $dkim->fetch_author_policy;
  my $policy_result = $policy->apply($dkim);

  my $policy = $dkim->fetch_sender_policy;
  my $policy_result = $policy->apply($dkim);

  $dkim->load($file_handle);

  my $address = $dkim->message_originator;

  my $email = $dkim->message_originator->address;

  my $address = $dkim->message_sender;

  my $email = $dkim->message_sender->address;

  my @policies = $dkim->policies;
  foreach my $policy (@policies)
  {
      $policy_result = $policy->apply($dkim);
      # $policy_result is one of "accept", "reject", "neutral"
  }

  my $result = $dkim->result;

  my $detail = $dkim->result_detail;

  pass
  fail (bad RSA signature)
  fail (OpenSSL error: ...)
  fail (message has been altered)
  fail (body has been altered)
  invalid (bad identity)
  invalid (invalid domain in d tag)
  invalid (missing q tag)
  invalid (missing d tag)
  invalid (missing s tag)
  invalid (unsupported version 0.1)
  invalid (unsupported algorithm ...)
  invalid (unsupported canonicalization ...)
  invalid (unsupported query protocol ...)
  invalid (signature is expired)
  invalid (public key: not available)
  invalid (public key: unknown query type ...)
  invalid (public key: syntax error)
  invalid (public key: unsupported version)
  invalid (public key: unsupported key type)
  invalid (public key: missing p= tag)
  invalid (public key: invalid data)
  invalid (public key: does not support email)
  invalid (public key: does not support hash algorithm 'sha1')
  invalid (public key: does not support signing subdomains)
  invalid (public key: revoked)
  invalid (public key: granularity mismatch)
  invalid (public key: granularity is empty)
  invalid (public key: OpenSSL error: ...)
  none

  my $sig = $dkim->signature;

  my @all_signatures = $dkim->signatures;

#!/usr/bin/perl

# Copyright 2005-2009 Messiah College. All rights reserved.
# 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;

use Mail::DKIM::Signature;
use Mail::DKIM::DkSignature;
use Mail::Address;

package Mail::DKIM::Verifier;
use base "Mail::DKIM::Common";
use Carp;
our $VERSION = 0.39;
our $MAX_SIGNATURES_TO_PROCESS = 50;

sub init
{
	my $self = shift;
	$self->SUPER::init;
	$self->{signatures} = [];
}

# @{$dkim->{signatures}}
#   array of L<Mail::DKIM::Signature> objects, representing all
#   parseable signatures found in the header,
#   ordered from the top of the header to the bottom.
#
# $dkim->{signature_reject_reason}
#   simple string listing a reason, if any, for not using a signature.
#   This may be a helpful diagnostic if there is a signature in the header,
#   but was found not to be valid. It will be ambiguous if there are more
#   than one signatures that could not be used.
#
# $dkim->{signature}
#   the L<Mail::DKIM::Signature> selected as the "best" signature.
#
# @{$dkim->{headers}}
#   array of strings, each member is one header, in its original format.
#
# $dkim->{algorithms}
#   array of algorithms, one for each signature being verified.
#
# $dkim->{result}
#   string; the result of the verification (see the result() method)
#

sub handle_header
{
	my $self = shift;
	my ($field_name, $contents, $line) = @_;

	$self->SUPER::handle_header($field_name, $contents);

	if (lc($field_name) eq "dkim-signature")
	{
		eval
		{
			my $signature = Mail::DKIM::Signature->parse($line);
			$self->add_signature($signature);
			$signature->fetch_public_key;
		};
		if ($@)
		{
			# the only reason an error should be thrown is if the
			# signature really is unparse-able

			# otherwise, invalid signatures are caught in finish_header()

			chomp (my $E = $@);
			$self->{signature_reject_reason} = $E;
		}
	}

	if (lc($field_name) eq "domainkey-signature")
	{
		eval
		{
			my $signature = Mail::DKIM::DkSignature->parse($line);
			$self->add_signature($signature);
			$signature->fetch_public_key;
		};
		if ($@)
		{
			# the only reason an error should be thrown is if the
			# signature really is unparse-able

			# otherwise, invalid signatures are caught in finish_header()

			chomp (my $E = $@);
			$self->{signature_reject_reason} = $E;
		}
	}
}

sub add_signature
{
	my $self = shift;
	croak "wrong number of arguments" unless (@_ == 1);
	my ($signature) = @_;

	# ignore signature headers once we've seen 50 or so
	# this protects against abuse.
	return if (@{$self->{signatures}} > $MAX_SIGNATURES_TO_PROCESS);

	push @{$self->{signatures}}, $signature;

	unless ($self->check_signature($signature))
	{
		$signature->result("invalid",
			$self->{signature_reject_reason});
		return;
	}

	# create a canonicalization filter and algorithm
	my $algorithm_class = $signature->get_algorithm_class(
				$signature->algorithm);
	my $algorithm = $algorithm_class->new(
				Signature => $signature,
				Debug_Canonicalization => $self->{Debug_Canonicalization},
			);

	# push through the headers parsed prior to the signature header
	if ($algorithm->wants_pre_signature_headers)
	{
		# Note: this will include the signature header that led to this
		# "algorithm"...
		foreach my $head (@{$self->{headers}})
		{
			$algorithm->add_header($head);
		}
	}

	# save the algorithm
	$self->{algorithms} ||= [];
	push @{$self->{algorithms}}, $algorithm;
}

sub check_signature
{
	my $self = shift;
	croak "wrong number of arguments" unless (@_ == 1);
	my ($signature) = @_;

	unless ($signature->check_version)
	{
		# unsupported version
		if (defined $signature->version)
		{
			$self->{signature_reject_reason} = "unsupported version "
				. $signature->version;
		}
		else
		{
			$self->{signature_reject_reason} = "missing v tag";
		}
		return 0;
	}

	unless ($signature->algorithm
		&& $signature->get_algorithm_class($signature->algorithm))
	{
		# unsupported algorithm
		$self->{signature_reject_reason} = "unsupported algorithm";
		if (defined $signature->algorithm)
		{
			$self->{signature_reject_reason} .= " " . $signature->algorithm;
		}
		return 0;
	}

	unless ($signature->check_canonicalization)
	{
		# unsupported canonicalization method
		$self->{signature_reject_reason} = "unsupported canonicalization";
		if (defined $signature->canonicalization)
		{
			$self->{signature_reject_reason} .= " " . $signature->canonicalization;
		}
		return 0;
	}

	unless ($signature->check_protocol)
	{
		# unsupported query protocol
		$self->{signature_reject_reason} =
			!defined($signature->protocol) ? "missing q tag"
			: "unsupported query protocol, q=" . $signature->protocol;
		return 0;
	}

	unless ($signature->check_expiration)
	{
		# signature has expired
		$self->{signature_reject_reason} = "signature is expired";
		return 0;
	}

	unless ($signature->domain ne '')
	{
		# no domain specified
		$self->{signature_reject_reason} =
			!defined($signature->domain) ? "missing d tag"
			: "invalid domain in d tag";
		return 0;
	}

	unless ($signature->selector)
	{
		# no selector specified
		$self->{signature_reject_reason} = "missing s tag";
		return 0;
	}

	return 1;
}

sub check_public_key
{
	my $self = shift;
	croak "wrong number of arguments" unless (@_ == 2);
	my ($signature, $public_key) = @_;

	my $result = 0;
	eval
	{
		$@ = undef;

		# HACK- I'm indecisive here about whether I want the
		# check_foo functions to return false or to "die"
		# on failure

		# check public key's allowed hash algorithms
		$result = $public_key->check_hash_algorithm(
				$signature->hash_algorithm);

		# HACK- DomainKeys signatures are allowed to have an empty g=
		# tag in the public key
		my $empty_g_means_wildcard = $signature->isa("Mail::DKIM::DkSignature");

		# check public key's granularity
		$result &&= $public_key->check_granularity(
				$signature->identity, $empty_g_means_wildcard);

		die $@ if $@;
	};
	if ($@)
	{
		my $E = $@;
		chomp $E;
		$self->{signature_reject_reason} = "public key: $E";
	}
	return $result;
}

# returns true if the i= tag is an address with a domain matching or
# a subdomain of the d= tag
#
sub check_signature_identity
{
	my ($signature) = @_;

	my $d = $signature->domain;
	my $i = $signature->identity;
	if (defined($i) && $i =~ /\@([^@]*)$/)
	{
		return match_subdomain($1, $d);
	}
	return 0;
}

sub match_subdomain
{
	croak "wrong number of arguments" unless (@_ == 2);
	my ($subdomain, $superdomain) = @_;

	my $tmp = substr(".$subdomain", -1 - length($superdomain));
	return (lc ".$superdomain" eq lc $tmp);
}

#
# called when the verifier has received the last of the message headers
# (body is still to come)
#
sub finish_header
{
	my $self = shift;

	# Signatures we found and were successfully parsed are stored in
	# $self->{signatures}. If none were found, our result is "none".

	if (@{$self->{signatures}} == 0
		&& !defined($self->{signature_reject_reason}))
	{
		$self->{result} = "none";
		return;
	}

	foreach my $algorithm (@{$self->{algorithms}})
	{
		$algorithm->finish_header(Headers => $self->{headers});
	}

	# stop processing signatures that are already known to be invalid
	@{$self->{algorithms}} = grep
		{
			my $sig = $_->signature;
			!($sig->result && $sig->result eq "invalid");
		} @{$self->{algorithms}};

	if (@{$self->{algorithms}} == 0
		&& @{$self->{signatures}} > 0)
	{
		$self->{result} = $self->{signatures}->[0]->result;
		$self->{details} = $self->{signatures}->[0]->{verify_details};
		return;
	}
}

sub _check_and_verify_signature
{
	my $self = shift;
	my ($algorithm) = @_;

		# check signature
		my $signature = $algorithm->signature;
		unless (check_signature_identity($signature))
		{
			$self->{signature_reject_reason} = "bad identity";
			return ("invalid", $self->{signature_reject_reason});
		}

		# get public key
		my $pkey;
		eval
		{
			$pkey = $signature->get_public_key;
		};
		if ($@)
		{
			my $E = $@;
			chomp $E;
			$self->{signature_reject_reason} = "public key: $E";
			return ("invalid", $self->{signature_reject_reason});
		}

		unless ($self->check_public_key($signature, $pkey))
		{
			return ("invalid", $self->{signature_reject_reason});
		}

		# verify signature
		my $result;
		my $details;
		local $@ = undef;
		eval
		{
			$result = $algorithm->verify() ? "pass" : "fail";
			$details = $algorithm->{verification_details} || $@;
		};
		if ($@)
		{
			# see also add_signature
			chomp (my $E = $@);
			if ($E =~ /(OpenSSL error: .*?) at /)
			{
				$E = $1;
			}
			elsif ($E =~ /^(panic:.*?) at /)
			{
				$E = "OpenSSL $1";
			}
			$result = "fail";
			$details = $E;
		}
	return ($result, $details);
}

sub finish_body
{
	my $self = shift;

	foreach my $algorithm (@{$self->{algorithms}})
	{
		# finish canonicalizing
		$algorithm->finish_body;

		my ($result, $details) = $self->_check_and_verify_signature($algorithm);

		# save the results of this signature verification
		$algorithm->{result} = $result;
		$algorithm->{details} = $details;
		$algorithm->signature->result($result, $details);

		# collate results ... ignore failed signatures if we already got
		# one to pass
		if (!$self->{result} || $result eq "pass")
		{
			$self->{signature} = $algorithm->signature;
			$self->{result} = $result;
			$self->{details} = $details;
		}
	}
}

sub fetch_author_domain_policies
{
	my $self = shift;
	use Mail::DKIM::AuthorDomainPolicy;

	return () unless $self->{headers_by_name}->{from};
	my @list = Mail::Address->parse(
		$self->{headers_by_name}->{from}
		);
	my @authors = map { $_->address } @list;

	# fetch the policies
	return map {
		Mail::DKIM::AuthorDomainPolicy->fetch(
			Protocol => "dns",
			Author => $_,
			)
		} @authors;
}

sub fetch_author_policy
{
	my $self = shift;
	my ($author) = @_;
	use Mail::DKIM::DkimPolicy;

	# determine address found in the "From"
	$author ||= $self->message_originator->address;

	# fetch the policy
	return Mail::DKIM::DkimPolicy->fetch(
			Protocol => "dns",
			Author => $author,
			);
}

sub fetch_sender_policy
{
	my $self = shift;
	use Mail::DKIM::DkPolicy;

	# determine addresses found in the "From" and "Sender" headers
	my $author = $self->message_originator->address;
	my $sender = $self->message_sender->address;

	# fetch the policy
	return Mail::DKIM::DkPolicy->fetch(
			Protocol => "dns",
			Author => $author,
			Sender => $sender,
			);
}

sub policies
{
	my $self = shift;

	my $sender_policy = eval { $self->fetch_sender_policy() };
	my $author_policy = eval { $self->fetch_author_policy() };
	return (
		$sender_policy ? $sender_policy : (),
		$author_policy ? $author_policy : (),
		$self->fetch_author_domain_policies(),
		);
}

sub signatures
{
	my $self = shift;
	croak "unexpected argument" if @_;

	return @{$self->{signatures}};
}

1;