qpsmtpd/plugins/domainkeys
Matt Simerson 5ec9695b94 domainkeys: added reject & reject_type options.
backwards compatible with previous warn_only option.

added additional logging

refactored out a couple new subs.

minor changes: added strictures, warnings, moved 'use' statements to top of code
2012-05-06 16:09:41 -07:00

153 lines
3.6 KiB
Perl

#!perl -w
=head1 NAME
domainkeys: validate a DomainKeys signature on an incoming mail
=head1 SYNOPSIS
domainkeys [reject 1]
Performs a DomainKeys validation on the message.
=head1 CONFIGURATION
=head2 reject
reject 1
Reject is a boolean that toggles message rejection on or off. Messages failing
DomainKeys validation are rejected by default.
=head2 reject_type
reject_type [ temp | perm ]
The default rejection type is permanent.
=head2 warn_only
A deprecated option that disables message rejection. See reject instead.
=head1 COPYRIGHT
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.
=head1 AUTHORS
Matt Simerson - 2012
John Peacock - 2005-2006
Anthony D. Urso. - 2004
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Mail::DomainKeys::Message;
use Mail::DomainKeys::Policy;
sub init {
my ($self, $qp, %args) = @_;
foreach my $key ( %args ) {
$self->{$key} = $args{$key};
}
$self->{reject} = 1 if ! defined $self->{reject}; # default reject
$self->{reject_type} = 'perm' if ! defined $self->{reject_type};
if ( $args{'warn_only'} ) {
$self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead");
$self->{'reject'} = 0;
};
}
sub hook_data_post {
my ($self, $transaction) = @_;
if ( ! $transaction->header->get('DomainKey-Signature') ) {
$self->log(LOGINFO, "skip: unsigned");
return DECLINED;
};
my $body = $self->assemble_body( $transaction );
my $message = load Mail::DomainKeys::Message(
HeadString => $transaction->header->as_string,
BodyReference => $body) or do {
$self->log(LOGWARN, "skip: unable to load message"),
return DECLINED;
};
# no sender domain means no verification
if ( ! $message->senderdomain ) {
$self->log(LOGINFO, "skip: failed to parse sender domain"),
return DECLINED;
};
my $status = $self->get_message_status( $message );
if ( defined $status ) {
$transaction->header->replace("DomainKey-Status", $status);
$self->log(LOGINFO, "pass: $status");
return DECLINED;
};
$self->log(LOGERROR, "fail: signature failed to verify");
return DECLINED if ! $self->{reject};
my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY;
return ($deny, "DomainKeys signature failed to verify");
}
sub get_message_status {
my ($self, $message) = @_;
if ( $message->testing ) {
return "testing"; # key testing, don't do anything else
};
if ( $message->signed && $message->verify ) {
return $message->signature->status; # verified: add good header
};
# not signed or not verified
my $policy = fetch Mail::DomainKeys::Policy(
Protocol => 'dns',
Domain => $message->senderdomain
);
if ( ! $policy ) {
return $message->signed ? "non-participant" : "no signature";
};
if ( $policy->testing ) {
return "testing"; # Don't do anything else
};
if ( $policy->signall ) {
return undef; # policy requires all mail to be signed
};
# $policy->signsome
return "no signature"; # not signed and domain doesn't sign all
};
sub assemble_body {
my ($self, $transaction) = @_;
$transaction->body_resetpos;
$transaction->body_getline; # \r\n seperator is NOT part of the body
my @body;
while (my $line = $transaction->body_getline) {
push @body, $line;
}
return \@body;
};