qpsmtpd/plugins/domainkeys

sub hook_data_post {
    use Mail::DomainKeys::Message;
    use Mail::DomainKeys::Policy;

    my ($self, $transaction) = @_;

    # if this isn't signed, just move along
    return DECLINED
    	unless $transaction->header->get('DomainKey-Signature');
	
    my @body;

    $transaction->body_resetpos;

    $transaction->body_getline; # \r\n seperator is NOT part of the body

    while (my $line = $transaction->body_getline) {
        push @body, $line;
    }

    my $message = load Mail::DomainKeys::Message(
        HeadString => $transaction->header->as_string,
        BodyReference => \@body) or
            $self->log(LOGWARN, "unable to load message"),
            return DECLINED;

    # no sender domain means no verification 
    $message->senderdomain or
        return DECLINED;

    my $status;

    # key testing
    if ( $message->testing ) {
	# Don't do anything else
	$status = "testing";
    }
    elsif ( $message->signed ) {
	if ( $message->verify ) {
	    # verified: add good header
	    $status = $message->signature->status;
	}
	else {
	    # not verified, i.e. forged signature
	    $status = undef;
	}
    }
    else { # not signed
	my $policy = fetch Mail::DomainKeys::Policy(
	    Protocol => "dns",
	    Domain => $message->senderdomain
	);
	if ( $policy ) {
	    if ( $policy->testing ) {
		# Don't do anything else
		$status = "testing";
	    }
	    elsif ( $policy->signall ) {
		# if policy requires all mail to be signed
		$status = undef;
	    }
	    else { # $policy->signsome
		# not signed and domain doesn't sign all
		$status = "no signature";
	    }
	}
	else {
	    $status = "no signature";
	}
    }

    
    if ( defined $status ) {
	$transaction->header->replace("DomainKey-Status", $status);
	return DECLINED;
    }
    else {	
	$self->log(LOGWARN, "DomainKeys signature failed to verify");
	return DECLINED;
    }
}

# Leave this in place until Mail::DomainKeys is patched
eval
  q/ 
    *Mail::DomainKeys::Message::header = sub {
    my $self = shift;

    $self->signed or
        return new Mail::DomainKeys::Header(
            Line => "DomainKey-Status: no signature");

    $self->signature->status and
        return new Mail::DomainKeys::Header(
        Line => "DomainKey-Status: " . $self->signature->status);
    };
   / 
unless Mail::DomainKeys::Message->can('header');

=cut

=head1 NAME

domainkeys: validate a DomainKeys signature on an incoming mail

Copyright (C) 2005-2006 John Peacock.

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