File Coverage

blib/lib/Mail/DomainKeys/Signature.pm

Criterion	Covered	Total	%
statement	81	152	53.2
branch	39	102	38.2
condition	4	12	33.3
subroutine	18	25	72.0
pod	0	21	0.0
total	142	312	45.5

# 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.

package Mail::DomainKeys::Signature;

use strict;

our $VERSION = "0.88";

sub new {
	my $type = shift;
	my %prms = @_;
	my $self = {};

	$self->{'ALGO'} = $prms{'Algorithm'};
	$self->{'DATA'} = $prms{'Signature'};
	$self->{'METH'} = $prms{'Method'};
	$self->{'DOMN'} = $prms{'Domain'};
	$self->{'HDRS'} = $prms{'Headers'};
	$self->{'PROT'} = $prms{'Query'};
	$self->{'SLCT'} = $prms{'Selector'};
	$self->{'SHDR'} = $prms{'SignHeaders'};
	$self->{'SIGN'} = $prms{'Signing'};
	$self->{'CFWS'} = $prms{'FWS'};

	bless $self, $type;
}

sub parse {
	my $type = shift;
	my %prms = @_;
	my $self = {};


	foreach my $tag (split /;/, $prms{"String"}) {
		$tag =~ s/^\s*|\s*$//g;

		foreach ($tag) {
			/^a=(rsa-sha1)$/i and
				$self->{'ALGO'} = lc $1;
			/^b=([A-Za-z0-9\+\/\=\s]+)$/ and
				$self->{'DATA'} = $1;
			/^c=(nofws|simple)$/i and
				$self->{'METH'} = lc $1;
			/^d=([A-Za-z0-9\-\.]+)$/ and
				$self->{'DOMN'} = lc $1;
			/^h=(.*)$/s and
				$self->{'HDRS'} = lc $1;
			/^q=(dns)$/i and
				$self->{'PROT'} = lc $1;
			/^s=(\S+)$/ and
				$self->{'SLCT'} = $1;
		}
	}

	bless $self, $type;
}

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

       # we are signing, and a list of headers to sign was specified
       if ($self->signheaderlist) {
               foreach my $key ($self->signheaderlist) {
                       lc $attr eq lc $key and
                               return 1;
               }

               return;
	}

       # we are verifying
       if ($self->headerlist) {
               foreach my $key ($self->headerlist) {
                       lc $attr eq lc $key and
                               return 1;
               }

               return;
       }

       # we are signing and a list of headers to sign was not specified,
       # or we are verifying and the DomainKeys-Signature header does not
       # have a h= term
       return 1;
}

sub as_string {
	my $self = shift;

	my $text;

	$self->algorithm and
		$text .= "a=" . $self->algorithm . "; ";

	$self->headerlist and
		$text .= "h=" . $self->headerlist . "; ";

	$text .= "q=" . $self->protocol . "; ";
	$text .= "c=" . $self->method . "; ";
	$text .= "s=" . $self->selector . "; ";
	$text .= "d=" . $self->domain . "; ";
	$text .= "b=" . $self->signature;

	if (defined (my $cfws = $self->fws)) {
		require Text::Wrap;

		local $Text::Wrap::columns = 78;

		$text = Text::Wrap::wrap("", $cfws, $text);
		$text .= "\n";
	}

	return $text;
}

sub sign {
	use MIME::Base64;

	my $self = shift;
	my %prms = @_;

	$self->method($prms{'Method'}) if $prms{'Method'};
	$self->selector($prms{'Selector'}) if $prms{'Selector'};
	$self->private($prms{'Private'}) if $prms{'Private'};

	my $text = $prms{'Text'} or
		$self->errorstr("no text given"),
		return;

	$self->method or
		$self->errorstr("no method specified"),
		return;

	$self->private or
		$self->errorstr("no private key specified"),
		return;

	$self->selector or
		$self->errorstr("no selector specified"),
		return;

	$self->domain or
		$self->errorstr("no domain specified"),
		return;

	$self->protocol or $self->protocol("dns");
	$self->algorithm or $self->algorithm("rsa-sha1");

	# d=... The value in this tag MUST match the domain of the sending
	# email address or MUST be one of the parent domains of the sending
	# email address. Domain name comparison is case insensitive.
	my $signing_domain = $self->domain;
	$prms{'Sender'}->host =~ /(^|\.)\Q$signing_domain\E\z/i or
		$self->errorstr("domain does not match address"),
		return;

	my $sign = $self->private->sign($text);
	my $signb64 = encode_base64($sign, "");

	$self->signature($signb64);

	$self->status("good");

	return 1;
}


sub verify {
	use Mail::DomainKeys::Key::Public;
	use MIME::Base64;

	my $self = shift;
	my %prms = @_;


	$self->status("bad format"),

	$self->selector or
		$self->errorstr("no selector specified"),
		return;

	$self->domain or
		$self->errorstr("no domain specified"),
		return;

	unless ($self->public) {
		my $pubk = fetch Mail::DomainKeys::Key::Public(
			Protocol => $self->protocol,
			Selector => $self->selector,
			Domain => $self->domain) or
				$self->status("no key"),
				$self->errorstr("no public key available"),
				return;

		$pubk->revoked and
			$self->status("revoked"),
			$self->errorstr("public key has been revoked"),
			return;

		$self->public($pubk);
	}

	$self->status("bad");

	# d=... The value in this tag MUST match the domain of the sending
	# email address or MUST be one of the parent domains of the sending
	# email address. Domain name comparison is case insensitive.
	my $signing_domain = $self->domain;
	$prms{'Sender'}->host =~ /(^|\.)\Q$signing_domain\E\z/i or
		$self->errorstr("domain does not match address"),
		return;

	$prms{'Sender'}->host eq $self->domain or
		$self->errorstr("domain does not match address"),
		return;

	$self->public->granularity and
		$prms{'Sender'}->user ne $self->public->granularity and
			$self->errorstr("granularity does not match address"),
			return;

	$self->public->verify(Text => $prms{'Text'},
		Signature => decode_base64($self->signature)) and
			$self->errorstr(undef),
			$self->status("good"),
			return 1;

	$self->errorstr("signature invalid");

	return;
}

sub algorithm {
	my $self = shift;

	@_ and
		$self->{'ALGO'} = shift;

	$self->{'ALGO'};
}

sub domain {
	my $self = shift;

	@_ and
		$self->{'DOMN'} = shift;

	$self->{'DOMN'};
}

sub errorstr {
	my $self = shift;

	@_ and
		$self->{'ESTR'} = shift;

	$self->{'ESTR'};
}

sub fws {
	my $self = shift;

	@_ and
		$self->{'CFWS'} = shift;

	return $self->{'CFWS'};
}

sub headerlist {
	my $self = shift;

	@_ and
		$self->{'HDRS'} = shift;

	if (wantarray and $self->{'HDRS'}) {
		my @list = split /[ \t]*:[ \t]*/, $self->{'HDRS'};
		return @list;
	}

	$self->{'HDRS'};
}

sub method {
	my $self = shift;

	@_ and
		$self->{'METH'} = shift;

	$self->{'METH'};
}

sub public {
	my $self = shift;

	@_ and
		$self->{'PBLC'} = shift;

	$self->{'PBLC'};
}

sub private {
	my $self = shift;

	@_ and
		$self->{'PRIV'} = shift;

	$self->{'PRIV'};
}

sub protocol {
	my $self = shift;

	@_ and
		$self->{'PROT'} = shift;

	$self->{'PROT'};
}

sub selector {
	my $self = shift;

	@_ and
		$self->{'SLCT'} = shift;

	$self->{'SLCT'};
}

sub signature {
	my $self = shift;

	@_ and
		$self->{'DATA'} = shift;

	$self->{'DATA'};
}

sub signheaderlist {
       my $self = shift;

       @_ and
               $self->{'SHDR'} = shift;

       if (wantarray and $self->{'SHDR'}) {
               my @list = split /:/, $self->{'SHDR'};
               return @list;
       }

       $self->{'SHDR'};
}

sub signing {
	my $self = shift;

	@_ and
		$self->{'SIGN'} = shift;

	$self->{'SIGN'};
}

sub status {
	my $self = shift;

	@_ and
		$self->{'STAT'} = shift;

	$self->{'STAT'};
}

sub testing {
	my $self = shift;

	$self->public and $self->public->testing and
		return 1;

	return;
}


1;