Mail::DKIM::Signature - represents a DKIM-Signature header

  my $signature = Mail::DKIM::Signature->new(
                      [ Algorithm => "rsa-sha1", ]
                      [ Signature => $base64, ]
                      [ Method => "relaxed", ]
                      [ Domain => "example.org", ]
                      [ Identity => 'user@example.org', ]
                      [ Headers => "from:subject:date:message-id", ]
                      [ Query => "dns", ]
                      [ Selector => "alpha", ]
                      [ Timestamp => time(), ]
                      [ Expiration => time() + 86400, ]
                  );

  my $sig = Mail::DKIM::Signature->parse(
                  "DKIM-Signature: a=rsa-sha1; b=yluiJ7+0=; c=relaxed"
            );

  print $signature->as_string . "\n";

  DKIM-Signature: a=rsa-sha1; b=yluiJ7+0=; c=relaxed

  print $signature->as_string_without_data . "\n";

  DKIM-Signature: a=rsa-sha1; b=; c=relaxed

  my $i = $signature->body_count;

  my $bh = $signature->body_hash;

  $signature->canonicalization("relaxed", "simple");

  ($header, $body) = $signature->canonicalization;

  my $base64 = $signature->data;
  $signature->data($base64);

  my $d = $signature->domain;          # gets the domain value
  $signature->domain("example.org");   # sets the domain value

  my $pubkey = $signature->get_public_key;

  my $raw_identity = $signature->get_tag("i");

  my $hash = $signature->hash_algorithm;

  $signature->headerlist("a:b:c");

  my $headerlist = $signature->headerlist;

  my @headers = $signature->headerlist;

  my $i = $signature->identity;

  my $key = $signature->key;

  $signature->key(Mail::DKIM::PrivateKey->load(File => "private.key"));

  my $result = $signature->result;

  $signature->result("pass");

  # to set the result with details
  $signature->result("invalid", "no public key");

  my $detail = $signature->result_detail;

  $signature->prettify;

  $signature->prettify_safe;

#!/usr/bin/perl

# Copyright 2005-2007 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::PublicKey;
use Mail::DKIM::Algorithm::rsa_sha1;
use Mail::DKIM::Algorithm::rsa_sha256;

package Mail::DKIM::Signature;
use base "Mail::DKIM::KeyValueList";
use Carp;

sub new
{
	my $class = shift;
	my %prms = @_;
	my $self = {};
	bless $self, $class;

	$self->version("1");
	$self->algorithm($prms{'Algorithm'} || "rsa-sha1");
	$self->signature($prms{'Signature'});
	$self->canonicalization($prms{'Method'}) if exists $prms{'Method'};
	$self->domain($prms{'Domain'});
	$self->headerlist($prms{'Headers'});
	$self->protocol($prms{'Query'}) if exists $prms{'Query'};
	$self->selector($prms{'Selector'});
	$self->identity($prms{'Identity'}) if exists $prms{'Identity'};
	$self->timestamp($prms{'Timestamp'}) if defined $prms{'Timestamp'};
	$self->expiration($prms{'Expiration'}) if defined $prms{'Expiration'};
	$self->key($prms{'Key'}) if defined $prms{'Key'};

	return $self;
}

sub parse
{
	my $class = shift;
	croak "wrong number of arguments" unless (@_ == 1);
	my ($string) = @_;

	# remove line terminator, if present
	$string =~ s/\015\012\z//;

	# remove field name, if present
	my $prefix;
	if ($string =~ /^(dkim-signature:)(.*)/si)
	{
		# save the field name (capitalization), so that it can be
		# restored later
		$prefix = $1;
		$string = $2;
	}

	my $self = $class->SUPER::parse($string);
	$self->{prefix} = $prefix;

	return $self;
}

# deprecated
sub wantheader {
	my $self = shift;
	my $attr = shift;

	$self->headerlist or
		return 1;
	
	foreach my $key ($self->headerlist) {
		lc $attr eq lc $key and
			return 1;
	}

	return;
}

sub algorithm
{
	my $self = shift;

	if (@_)
	{
		$self->set_tag("a", shift);
	}

	my $a = $self->get_tag("a");
	return defined $a ? lc $a : undef;
}	

sub as_string
{
	my $self = shift;

	my $prefix = $self->{prefix} || $self->DEFAULT_PREFIX;

	return $prefix . $self->SUPER::as_string;
}

# undocumented method
sub as_string_debug
{
	my $self = shift;

	my $prefix = $self->{prefix} || $self->DEFAULT_PREFIX;

	return $prefix . join(";", map { ">" . $_->{raw} . "<" } @{$self->{tags}});
}

sub as_string_without_data
{
	my $self = shift;
	croak "wrong number of arguments" unless (@_ == 0);

	my $alt = $self->clone;
	$alt->signature("");

	return $alt->as_string;
}

sub body_count
{
	my $self = shift;

	# set new body count if provided
	(@_) and
		$self->set_tag("l", shift);

	return $self->get_tag("l");
}

sub body_hash
{
	my $self = shift;

	# set new body hash if provided
	(@_) and
		$self->set_tag("bh", shift);

	my $result = $self->get_tag("bh");
	if (defined $result)
	{
		$result =~ s/\s+//gs;
	}
	return $result;
}

sub canonicalization
{
	my $self = shift;

	if (@_)
	{
		$self->set_tag("c", join("/", @_));
	}

	my $c = $self->get_tag("c");
	$c = lc $c  if defined $c;
	if (not $c)
	{
		$c = "simple/simple";
	}
	my ($c1, $c2) = split(/\//, $c, 2);
	if (not defined $c2)
	{
		# default body canonicalization is "simple"
		$c2 = "simple";
	}

	if (wantarray)
	{
		return ($c1, $c2);
	}
	else
	{
		return "$c1/$c2";
	}
}	

use MIME::Base64;

# checks whether this signature specifies a legal canonicalization method
# returns true if the canonicalization is acceptable, false otherwise
#
sub check_canonicalization
{
	my $self = shift;

	my ($c1, $c2) = $self->canonicalization;

	my @known = ("nowsp", "simple", "relaxed");
	return undef unless (grep { $_ eq $c1 } @known);
	return undef unless (grep { $_ eq $c2 } @known);
	return 1;
}

# checks whether the expiration time on this signature is acceptable
# returns a true value if acceptable, false otherwise
#
sub check_expiration
{
	my $self = shift;
	my $x = $self->expiration;
	return 1 if not defined $x;

	$self->{_verify_time} ||= time();
	return ($self->{_verify_time} <= $x);
}

# checks whether the protocol found on this signature is valid for
# fetching the public key
# returns a true value if protocol is "dns/txt", false otherwise
#
sub check_protocol
{
	my $self = shift;

	my ($type, $options) = split(/\//, $self->protocol, 2);
	return unless ($type eq "dns");
	return if ($options && $options ne "txt");

	my $v = $self->version;
	if ($v)
	{
		# in v=1 signatures, the /txt option is REQUIRED
		return unless ($options && $options eq "txt");
	}
	return 1;
}

# checks whether the version tag has an acceptable value
# returns true if so, otherwise false
#
sub check_version
{
	my $self = shift;

	# check version
	if (my $version = $self->version)
	{
		my @ALLOWED_VERSIONS = ("0.5", "1");
		return (grep {$_ eq $version} @ALLOWED_VERSIONS);
	}

	# we still consider a missing v= tag acceptable,
	# for backwards-compatibility
	return 1;
}

sub data
{
	my $self = shift;

	if (@_)
	{
		$self->set_tag("b", shift);
	}

	my $b = $self->get_tag("b");
	$b =~ tr/\015\012 \t//d  if defined $b;
	return $b;
}	

*signature = \*data;

#undocumented, private function
#derived from MIME::Base64::Perl (allowed, thanks to the Perl license)
#
sub decode_qp
{
	my $res = shift;

	#TODO- should I worry about non-ASCII systems here?
	$res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge
		if defined $res;
	return $res;
}

#undocumented, private function
#derived from MIME::Base64::Perl (allowed, thanks to the Perl license)
#
sub encode_qp
{
	my $res = shift;

	# note- unlike MIME quoted-printable, we don't allow whitespace chars
	my $DISALLOWED = qr/[^!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~]/;

	#TODO- should I worry about non-ASCII systems here?
	$res =~ s/($DISALLOWED)/sprintf('=%02X', ord($1))/eg
		if defined $res;
	return $res;
}

sub DEFAULT_PREFIX
{
	return "DKIM-Signature:";
}

sub domain
{
	my $self = shift;

	if (@_)
	{
		$self->set_tag("d", shift);
	}

	my $d = $self->get_tag("d");
	return defined $d ? lc $d : undef;
}	

sub expiration
{
	my $self = shift;

	(@_) and
		$self->set_tag("x", shift);
	
	return $self->get_tag("x");
}

# allows the type of signature to determine what "algorithm" gets used
sub get_algorithm_class
{
	my $self = shift;
	croak "wrong number of arguments" unless (@_ == 1);
	my ($algorithm) = @_;

	my $class =
		$algorithm eq "rsa-sha1" ? "Mail::DKIM::Algorithm::rsa_sha1" :
		$algorithm eq "rsa-sha256" ? "Mail::DKIM::Algorithm::rsa_sha256" :
		undef;
	return $class;
}

# [private method]
# fetch_public_key() - initiate a DNS query for fetching the key
#
# This method does NOT return the public key.
# Use get_public_key() for that.
#
sub fetch_public_key
{
	my $self = shift;
	return if exists $self->{public_key_query};

	my $on_success = sub {
			if ($_[0]) {
				$self->{public} = $_[0];
			} else {
				$self->{public_error} = "not available\n";
			}
		};

	$self->{public_key_query} =
		Mail::DKIM::PublicKey->fetch_async(
			Protocol => $self->protocol,
			Selector => $self->selector,
			Domain => $self->domain,
			Callbacks => {
			Success => $on_success,
			Error => sub { $self->{public_error} = shift },
			},
			);
	return;
}

#EXPERIMENTAL
sub _refetch_public_key
{
	my $self = shift;
	if ($self->{public_key_query})
	{
		# clear the existing query by waiting for it to complete
		$self->{public_key_query}->();
	}
	delete $self->{public_key_query};
	delete $self->{public};
	delete $self->{public_error};
	$self->fetch_public_key;
}

sub get_public_key
{
	my $self = shift;

	# this ensures we only try fetching once, even if an error occurs
	if (not exists $self->{public_key_query})
	{
		$self->fetch_public_key;
	}

	if ($self->{public_key_query})
	{
		# wait for public key query to finish
		$self->{public_key_query}->();
		$self->{public_key_query} = 0;
	}

	if (exists $self->{public})
	{
		return $self->{public};
	}
	else
	{
		die $self->{public_error};
	}
}

sub hash_algorithm
{
	my $self = shift;
	my $algorithm = $self->algorithm;

	return $algorithm eq "rsa-sha1" ? "sha1" :
		$algorithm eq "rsa-sha256" ? "sha256" : undef;
}

sub headerlist
{
	my $self = shift;

	(@_) and
		$self->set_tag("h", shift);

	my $h = $self->get_tag("h") || "";

	# remove whitespace next to colons
	$h =~ s/\s+:/:/g;
	$h =~ s/:\s+/:/g;
	$h = lc $h;

	if (wantarray and $h)
	{
		my @list = split /:/, $h;
		@list = map { s/^\s+|\s+$//g; $_ } @list;
		return @list;
	}
	elsif (wantarray)
	{
		return ();
	}

	return $h;
}	

sub identity
{
	my $self = shift;

	# set new identity if provided
	(@_) and
		$self->set_tag("i", encode_qp(shift));

	my $i = $self->get_tag("i");
	if (defined $i)
	{
		return decode_qp($i);
	}
	else
	{
		return '@' . $self->domain;
	}
}

sub identity_matches
{
	my $self = shift;
	my ($addr) = @_;

	my $id = $self->identity;
	if ($id =~ /^\@/)
	{
		# the identity is a domain-name only, so it only needs to match
		# the domain part of the sender address
		return (lc(substr($addr, -length($id))) eq lc($id));

		# TODO - compare the parent domains?
	}
	return lc($addr) eq lc($id);
}

sub key
{
	my $self = shift;
	if (@_)
	{
		$self->{Key} = shift;
		$self->{KeyFile} = undef;
	}
	return $self->{Key};
}

sub method
{
	my $self = shift;

	if (@_)
	{
		$self->set_tag("c", shift);
	}

	return (lc $self->get_tag("c")) || "simple";
}	

sub protocol {
	my $self = shift;

	(@_) and
		$self->set_tag("q", shift);

	my $q = $self->get_tag("q");
	if (not defined $q)
	{
		return "dns/txt";
	}
	elsif ($q =~ m#/#)
	{
		return $q;
	}
	else
	{
		return "$q/";
	}
}	

sub result
{
	my $self = shift;
	@_ and $self->{verify_result} = shift;
	@_ and $self->{verify_details} = shift;
	return $self->{verify_result};
}

sub result_detail
{
	my $self = shift;
	croak "wrong number of arguments" unless (@_ == 0);

	if ($self->{verify_result} && $self->{verify_details})
	{
		return $self->{verify_result} . " (" . $self->{verify_details} . ")";
	}
	return $self->{verify_result};
}

sub selector {
	my $self = shift;

	(@_) and
		$self->set_tag("s", shift);

	return $self->get_tag("s");
}	

sub prettify
{
	my $self = shift;
	$self->wrap(
		Start => length($self->{prefix} || $self->DEFAULT_PREFIX),
		Tags => {
			b => "b64",
			bh => "b64",
			h => "list",
			},
		);
}

sub prettify_safe
{
	my $self = shift;
	$self->wrap(
		Start => length($self->{prefix} || $self->DEFAULT_PREFIX),
		Tags => {
			b => "b64",
			},
		PreserveNames => 1,
		Default => "preserve", #preserves unknown tags
		);
}

sub timestamp
{
	my $self = shift;

	(@_) and
		$self->set_tag("t", shift);
	
	return $self->get_tag("t");
}

sub version
{
	my $self = shift;

	(@_) and
		$self->set_tag("v", shift);

	return $self->get_tag("v");
}

1;