smeserver/smeserver-qpsmtpd
6
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

initial commit of file from CVS for smeserver-qpsmtpd on Thu 26 Oct 11:25:19 BST 2023

Browse Source
This commit is contained in:
Brian Read
2023-10-26 11:25:19 +01:00
parent c8bfca82cb
commit c45ac2b2d0
197 changed files with 3867 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

96
root/usr/share/qpsmtpd/plugins/check_smtp_forward Normal file
View File

@@ -0,0 +1,96 @@
=head1 NAME
check_smtp_forward
=head1 DESCRIPTION
This plugin checks whether SMTP forwarding would be allowed for this
recipient by connecting to the internal mail server.
If the internal mail server rejects the mail, we DENY it.
If the internal mail server would accept the mail, we DECLINE.
If the internal mail server cannot be contacted, we DENYSOFT.
=head1 CONFIG
Reads smtproutes to determine where to send mail for various domains.
Ignores any default smtproutes entries as they are for upstream mail
servers (e.g. ISP).
=head1 AUTHOR
Copyright 2006 Gordon Rowell <gordonr@gormand.com.au>
This software is free software and may be distributed under the same
terms as qpsmtpd itself.
Based in part on the smtp-forward plugin from the qpsmtpd distribution.
=cut
use Net::SMTP;
sub register {
my ($self, $qp, @args) = @_;
for my $smtp_route ($self->qp->config("smtproutes"))
{
$smtp_route =~ s/[ \[ \] ]//g;
my ($host, $server) = $smtp_route =~ m/(\S+):(\S+)/;
next unless ($host);
$self->{_smtp_host}{$host} = $server;
$self->log(LOGDEBUG, "$host: $server");
}
}
sub hook_rcpt {
my ($self, $transaction, $recipient) = @_;
my $host = lc $recipient->host;
my $server = $self->{_smtp_host}{$host} or return (DECLINED);
my $port;
($server, $port) = split(/:/, $server);
$port ||= 25;
$self->log(LOGDEBUG, "Checking $recipient on $server:$port");
my $smtp = Net::SMTP->new(
$server,
Port => $port,
Timeout => 60,
Hello => $self->qp->config("me"),
) || return (DENYSOFT,
"Unable to connect to $server: $!");
$smtp->mail( $transaction->sender->address || "" );
my $rc = $smtp->code;
my $message = $smtp->message;
chomp($message);
if ($rc =~ m/^4\d{2}$/ ) {
return(DENYSOFT, "Unable to queue message ($message)");
} elsif ($rc =~ m/^5\d{2}$/ ) {
return(DENY, "Unable to queue message ($message)");
}
$smtp->to($recipient->address);
$rc = $smtp->code;
$message = $smtp->message;
chomp($message);
if ($rc =~ m/^4\d{2}$/ ) {
return(DENYSOFT, "Unable to queue message ($message)");
} elsif ($rc =~ m/^5\d{2}$/ ) {
return(DENY, "Unable to queue message ($message)");
}
$smtp->quit();
$rc = $smtp->code;
$self->log(LOGDEBUG, "$server would accept message to $recipient");
return DECLINED; # Internal mail server is happy
}

124
root/usr/share/qpsmtpd/plugins/disclaimer Normal file
View File

@@ -0,0 +1,124 @@
use MIME::Parser;
use MIME::Entity;
sub register {
my ($self, $qp, @args) = @_;
$self->log(LOGERROR, "Bad parameters for the disclaimer plugin")
if @_ % 2;
%{$self->{_args}} = @args;
}
sub read_disclaimer {
my ($self, $disclaimer_file) = @_;
my $disclaimer_dir = $self->{_args}->{disclaimer_dir} || "/service/qpsmtpd/config/";
return () unless open DISCLAIMER, "<$disclaimer_dir/$disclaimer_file";
my @lines = <DISCLAIMER>;
chomp @lines;
close DISCLAIMER;
return @lines;
}
sub hook_data_post {
my ($self, $transaction) = @_;
if ( $transaction->header->get('X-Qpsmtp-Disclaimer') ) {
$self->log(LOGNOTICE, "Message already has disclaimer attached");
return DECLINED;
}
$self->qp->version =~ m/([\.\d]+).*/;
my $versionnum = $1;
my @rcpt_hosts = ($self->qp->config("me"), $self->qp->config("rcpthosts"));
my $fromhost = $transaction->sender->host;
unless ( $self->{_args}->{tag_all} ) {
my $fromlocal = 0;
for my $allowed (@rcpt_hosts) {
$allowed =~ s/^\s*(\S+)/$1/;
($fromlocal = 1, last) if (($fromhost eq lc $allowed) or (substr($allowed,0,1) eq "." and
$fromhost =~ m/\Q$allowed\E$/i));
}
if (($versionnum >= 0.26) and ($fromlocal == 0)) {
my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map');
$fromlocal = 1 if exists $more_rcpt_hosts->{$fromhost};
}
unless ($fromlocal) {
$self->log(LOGDEBUG, "Not from local domain");
return DECLINED;
}
}
my $specific = 0;
my @lines;
if ( @lines = $self->read_disclaimer("disclaimer_$fromhost") ) {
$self->log(LOGDEBUG, "Found disclaimer for domain: $fromhost");
$specific = 1;
} elsif ( @lines = $self->read_disclaimer("disclaimer") ) {
$self->log(LOGDEBUG, "Found general disclaimer");
} else {
$self->log(LOGERROR, "No disclaimer found for domain: $fromhost");
return DECLINED;
}
unless ( $self->{_args}->{tag_all} ) {
my $toexternal=0;
foreach my $rcpt ( $transaction->recipients ) {
my $local = 0;
my $host = $rcpt->host;
($toexternal = 1, last) if ( $specific && $host ne $fromhost);
for my $allowed (@rcpt_hosts) {
$allowed =~ s/^\s*(\S+)/$1/;
($local = 1, last) if (($host eq lc $allowed) or (substr($allowed,0,1) eq "." and
$host =~ m/\Q$allowed\E$/i));
}
if (($versionnum >= 0.26) and ($local == 0)) {
my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map');
$local = 1 if exists $more_rcpt_hosts->{$host};
}
($toexternal = 1, last) unless $local;
}
unless ($toexternal) {
$self->log(LOGDEBUG, "Not to any external domain");
return DECLINED;
}
}
my $parser = new MIME::Parser;
$parser->output_under( $self->spool_dir() );
$parser->extract_uuencode(1);
my $ent = $parser->parse_open( $transaction->body_filename() );
$ent->make_multipart( 'mixed', Force => 1 ) if $ent->mime_type ne 'multipart/mixed';
$ent->attach( Data => join("\n", @lines),
Encoding => $self->{_args}->{mime_encoding} || '-SUGGEST',
Filename => $self->{_args}->{mime_filename} || 'disclaimer.txt',
Type => $self->{_args}->{mime_type} || 'text/plain');
if ($ent->parts <= 2) {
$transaction->header->empty();
$transaction->header($ent->head());
}
$transaction->header->replace( 'X-Qpsmtp-Disclaimer', $fromhost );
$self->log(LOGNOTICE, "Attached disclaimer for domain: $fromhost");
open BFN, ">" . $transaction->body_filename();
$ent->print(\*BFN);
close BFN;
$transaction->body_resetpos();
$ent->purge();
rmdir( $parser->output_dir );
return DECLINED;
}
# vi: ft=perl ts=4

77
root/usr/share/qpsmtpd/plugins/dkim_sign Normal file
View File

@@ -0,0 +1,77 @@
=head1 NAME
dkim_sigh: attach a DKIM or DomainKeys signature to incoming mail before it is queued.
Currently we sign all authenticated and allowed relay email.
written by Shad L. Lords
=cut
require Mail::DKIM::Signer;
require Mail::DKIM::DkSignature;
sub register {
my ($self, $qp, @args) = @_;
%{$self->{_dkim}} = @args;
}
sub hook_data_post {
my $self = shift;
my $trns = shift;
return DECLINED unless $self->qp->connection->relay_client() || ( $self->qp->auth_mechanism() && $self->qp->auth_user() );
my $sender = (Qpsmtpd::Address->parse($trns->sender))[0];
return DECLINED unless $sender;
my $dkim = new Mail::DKIM::Signer(
Policy => sub {
my $dkim = shift;
my $headers = $self->{_dkim}->{dkim_headers} || "received:from:subject:date:message-id";
$headers = $dkim->headers if $headers eq 'all';
my $keys = $self->{_dkim}->{keys} || 'both';
$dkim->add_signature(new Mail::DKIM::DkSignature(
Algorithm => $self->{_dkim}->{algorithm} || "rsa-sha1",
Method => $self->{_dkim}->{dk_method} || "nofws",
Selector => $self->{_dkim}->{selector} || "default",
Domain => $dkim->message_sender->host,
Headers => $headers,
)) if $keys eq 'both' || $keys eq 'dk' || $keys eq 'domainkeys';
$dkim->add_signature(new Mail::DKIM::Signature(
Algorithm => $self->{_dkim}->{algorithm} || "rsa-sha1",
Method => $self->{_dkim}->{dkim_method} || "relaxed",
Selector => $self->{_dkim}->{selector} || "default",
Domain => $dkim->message_sender->host,
Headers => $headers,
)) if $keys eq 'both' || $keys eq 'dkim';
return 1;
},
KeyFile => "config/dkimkeys/".$sender->host.".private"
);
return DECLINED unless $dkim;
$trns->body_resetpos;
foreach my $line (split /\n/, $trns->header->as_string) {
chomp $line;
$dkim->PRINT("$line\015\012");
}
while (my $line = $trns->body_getline) {
chomp $line;
$dkim->PRINT("$line\015\012");
}
$dkim->CLOSE;
foreach my $sig ($dkim->signatures) {
if ( (my $sig_string = $sig->as_string) =~ /^([^:]+):\s*(.*)$/) {
$self->log(LOGINFO, "Added $1 for domain ".$sender->host);
$trns->header->add("$1:", $2, 0);
}
}
return DECLINED;
}

61
root/usr/share/qpsmtpd/plugins/forcespamcheck Normal file
View File

@@ -0,0 +1,61 @@
#!perl -w
=head1 NAME
forcespamcheck - SpamAssassin integration for qpsmtpd
=head1 DESCRIPTION
Plugin that forces check if the mail is spam by using the "spamd" daemon
from the SpamAssassin package. F<http://www.spamassassin.org>
=head1 CONFIG
This plugins needs spamassassin like arguments
Refer to spamassassin plugin
On top of that it uses a config file with an ip per line corresponding of
local_ip of the qpsmtpd server on which the remote client is trying to deliver
the mail. Please be cautious this is not the remote client ip !
THe initial idea is to force spam check for some deamons by making them
sending to 127.0.0.200:25 so other daemons trying to deliver on 127.0.0.1:25
or LAN client delivering on 192.168.0.1:25 will avoid the spam check, unless you
also specify those ips in forcespamcheck file.
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Qpsmtpd::DSN;
use Socket qw(:DEFAULT :crlf);
use IO::Handle;
sub register {
my ($self, $qp, %args) = @_;
$self->log(LOGERROR, "Bad parameters for the forcespamcheck plugin")
if @_ % 2;
#first if spamassassin already loaded return DECLINED; not to load it twice
my @datahooked = $qp->hooks('data_post');
for my $item (@datahooked) {
$self->log(LOGNOTICE,"spamassassin aleady loaded") if $item->{name} eq "spamassassin";
return DECLINED if $item->{name} eq "spamassassin";
}
# else we can go on
my $param = join(q{ }, map{qq{$_ $args{$_}}} keys %args);
my $ip = $self->qp->connection->local_ip;
# read here list of ip from file; or default on 127.0.0.200
my %forcespamcheck = map { $_ => 1 } $self->qp->config('forcespamcheck');
# we force spamcheck on 127.0.0.200 as used by fetchmail
$forcespamcheck{'127.0.0.200'} = 1;
return DECLINED unless (exists $forcespamcheck{$ip});
my $plugin_line = "spamassassin " . $param;
my $this_plugin = $self->qp->_load_plugin($plugin_line, $self->qp->plugin_dirs);
$self->register_hook('data', 'data_handler');
}
sub data_handler {
my ($self, $transaction) = @_;
my $ip = $self->qp->connection->local_ip;
# logged only there to avoid double line in log in register.
$self->log(LOGINFO,
"forcing spamassassin check for connection on $ip");
}

172
root/usr/share/qpsmtpd/plugins/logging/logterse Normal file
View File

@@ -0,0 +1,172 @@
=pod
=head1 SYNOPSIS
logterse [prefix char] [loglevel level]
This plugin is not a logging replacement, but rather an adjunct to the normal logging
plugins or builtin logging functionality. Specify it in config/plugins not
config/logging or you'll get "interesting" results.
The idea is to produce a one-line log entry that summarises the outcome of a
transaction. A message is either queued or rejected (bizarre failure modes are
not of interest). What is of interest is the details of the sending host and the
message envelope, and what happened to the message. To do this we hook_deny and
hook_queue and grab as much info as we can.
This info is then passed to the real logging subsystem as a single line with
colon-separated fields as follows:
=over 4
=item 1. remote ip
=item 2. remote hostname
=item 3. helo host
=item 4. envelope sender
=item 5. recipient (comma-separated list if more than one)
=item 6. name of plugin that called DENY, or the string 'queued' if message was accepted.
=item 7. return value of DENY plugin (empty if message was queued).
=item 8. the DENY message, or the message-id if it was queued.
=item 9. details of spammassassin scores if messaged was accepted or denied due to score requiring rejection
or 'msg denied before queued' if other rejections occur.
=back
As with logging/adaptive, a distinctive prefix (the backquote character by default) is
used to make it easy to extract the lines from the main logfiles, or to take advantage
of multilog's selection capability as described in the logging/adaptive plugin:
=head1 TYPICAL USAGE
If you are using multilog to handle your logging, you can replace the system
provided log/run file with something like this:
#! /bin/sh
export LOGDIR=./main
exec multilog t n10 \
$LOGDIR \
'-*' '+*` *' $LOGDIR/summary
which will have the following effects:
=over 4
=item 1. All lines will be logged in ./main as usual.
=item 2. ./main/summary will contain only the lines output by this plugin.
=back
=head1 AUTHORS
Written by Charles Butcher who took a lot from logging/adaptive by John Peacock.
Added to by Brian Read (March 2007) to add in the spamassassin scores.
=head1 VERSION
This is release 1.1
=cut
#
# I chose tab as the field separator to help with human-readability of the logs and hopefully minimal
# chance of a tab showing up _inside_ a field (although they are converted if they do).
# If you change it here, remember to change it in qplogsumm.pl as well.
#
my $FS = "\t";
#my $FS = "\&";
sub register {
my ( $self, $qp, %args ) = @_;
$self->{_prefix} = '`';
if ( defined $args{prefix} and $args{prefix} =~ /^(.+)$/ ) {
$self->{_prefix} = $1;
}
$self->{_loglevel} = LOGALERT;
if ( defined( $args{loglevel} ) ) {
if ( $args{loglevel} =~ /^\d+$/ ) {
$self->{_loglevel} = $args{loglevel};
}
else {
$self->{_loglevel} = log_level( $args{loglevel} );
}
}
}
sub hook_deny {
my ( $self, $transaction, $prev_hook, $retval, $return_text ) = @_;
my $disposition = join($FS,
$prev_hook,
$retval,
$return_text,
);
$self->_log_terse($transaction, $disposition);
return DECLINED;
}
sub hook_queue {
my ( $self, $transaction ) = @_;
my $msg_id = $transaction->header->get('Message-Id') || '';
$msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here
$msg_id = "<$msg_id>" unless $msg_id =~ /^<.*>$/; # surround in <>'s
my $disposition = "queued$FS$FS$msg_id";
$self->_log_terse($transaction, $disposition);
return DECLINED;
}
sub _log_terse {
my ( $self, $transaction, $disposition ) = @_;
my $recipients = join(',', $transaction->recipients);
my $remote_ip = $self->qp->connection->remote_ip() || '';
my $remote_host = $self->qp->connection->remote_host() || '';
my $hello_host = $self->qp->connection->hello_host() || '';
my $tx_sender = $transaction->sender() || '';
my $spamscore = 'msg denied before queued';
if (substr($disposition,0,6) =~ 'queued|spamas') {
$spamscore = $transaction->header->get('X-Spam-Status') || '';
# just pull out scores
$spamscore = substr($spamscore,0,index($spamscore,'tests')-1);
map(s/\n/_/g,$spamscore)
}
my @log_message;
push(@log_message,
$remote_ip,
$remote_host,
$hello_host,
$tx_sender,
$recipients
);
#
# Escape any $FS characters anywhere in the log message
#
map {s/$FS/_/g} @log_message;
push(@log_message, $disposition);
push(@log_message, $spamscore);
$self->log($self->{_loglevel}, $self->{_prefix}, join($FS, @log_message));
}

120
root/usr/share/qpsmtpd/plugins/peers Normal file
View File

@@ -0,0 +1,120 @@
# this plugin checks the peers directory for config
# file most closely matching the client IP address
# and loads it if found.
#
# Note that init() borrows some internals from Qpsmtpd.pm - I
# didn't see a suitable public interface.
sub init {
my $self = shift;
my $qp = shift;
my $plugins_list_file = shift || 'peers/0';
my @plugins = $qp->config($plugins_list_file);
my @plugin_dirs = $qp->plugin_dirs;
for my $plugin_line (@plugins) {
my ($plugin, @args) = split ' ', $plugin_line;
my $package;
if ($plugin =~ m/::/) {
# "full" package plugin (My::Plugin)
$package = $plugin;
$package =~ s/[^_a-z0-9:]+//gi;
my $eval = qq[require $package;\n]
.qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
die "Failed loading $package - eval $@" if $@;
$self->log(LOGDEBUG, "Loading $package ($plugin_line)")
unless $plugin_line =~ /logging/;
}
else {
# regular plugins/$plugin plugin
my $plugin_name = $plugin;
$plugin =~ s/:\d+$//; # after this point, only used for filename
# Escape everything into valid perl identifiers
$plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
# second pass cares for slashes and words starting with a digit
$plugin_name =~ s{
(/+) # directory
(\d?) # package's first character
}[
"::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
]egx;
$package = "Qpsmtpd::Plugin::$plugin_name";
# don't reload plugins if they are already loaded
unless ( defined &{"${package}::plugin_name"} ) {
PLUGIN_DIR: for my $dir (@plugin_dirs) {
if (-e "$dir/$plugin") {
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
Qpsmtpd->varlog(LOGDEBUG, "init", "peers", "Loading $plugin_line from $dir/$plugin")
unless $plugin_line =~ /logging/;
last PLUGIN_DIR;
}
}
}
}
}
return 1;
}
sub _peer_plugins {
my $qp = shift;
my $hook = shift;
my $config = shift;
my $hooks;
$hooks->{$_} = delete $qp->hooks->{$_} foreach keys %{$qp->hooks};
my @plugins = $qp->config($config);
unshift @plugins, "peers $config";
my @loaded;
for my $plugin_line (@plugins) {
my $this_plugin = $qp->_load_plugin($plugin_line, $qp->plugin_dirs);
push @loaded, $this_plugin if $this_plugin;
}
if ($hook eq 'set_hooks') {
foreach my $c (@{$hooks->{connect}}) {
unshift @{$qp->hooks->{connect}}, $c unless grep { $c->{name} eq $_->{name} } @{$hooks->{connect}};
}
}
return @loaded;
}
sub hook_set_hooks {
my ($self, $transaction) = @_;
my $qp = $self->qp;
my $connection = $qp->connection;
my $client_ip = $qp->connection->remote_ip;
while ($client_ip) {
if (-f "config/peers/$client_ip") {
_peer_plugins($qp, "set_hooks", "peers/$client_ip");
return (DECLINED);
}
$client_ip =~ s/\.?\d+$//; # strip off another 8 bits
}
if (-f "config/peers/0") {
_peer_plugins($qp, "set_hooks", "peers/0");
return (DECLINED);
}
return (DENY);
}
sub hook_valid_auth {
my ( $self, $transaction) = @_;
my $qp = $self->qp;
_peer_plugins($qp, "valid_auth", "peers/local") if (-f "config/peers/local");
return (DECLINED);
}

237
root/usr/share/qpsmtpd/plugins/tnef2mime Normal file
View File

@@ -0,0 +1,237 @@
#!/usr/bin/perl -w
=head1 NAME
tnef2mime
=head1 DESCRIPTION
Plugin that converts ms-tnef attachments (winmail.dat) and uuencoded attachments to MIME.
perl-Convert-TNEF, perl-IO-stringy, perl-File-MMagic and perl-MIME-tools are required.
=head1 AUTHOR
Michael Weinberger, neddix Stuttgart, 2005
=head1 LICENSE
GNU GPL (GNU General Public License)
=cut
use MIME::Parser;
{
# this is a dirty fix regarding this bug https://rt.cpan.org/Ticket/Display.html?id=97886
# this way we can keep on usinhg this plugin waiting for the upstream fix
# the no warnings avoid message in qpsmtpd log on every mails saying we override the sub.
no warnings;
*MIME::Parser::Filer::output_path = sub {
my ($self, $head) = @_;
### Get the output directory:
my $dir = $self->output_dir($head);
### Get the output filename as UTF-8
my $fname = $head->recommended_filename;
### Can we use it:
if (!defined($fname)) {
$self->debug("no filename recommended: synthesizing our own");
$fname = $self->output_filename($head);
}
elsif ($self->ignore_filename) {
$self->debug("ignoring all external filenames: synthesizing our own");
$fname = $self->output_filename($head);
}
elsif ($self->evil_filename($fname)) {
### Can we save it by just taking the last element?
my $ex = $self->exorcise_filename($fname);
if (defined($ex) and !$self->evil_filename($ex)) {
$self->whine("Provided filename '$fname' is regarded as evil, ",
"but I was able to exorcise it and get something ",
"usable.");
$fname = $ex;
}
else {
$self->whine("Provided filename '$fname' is regarded as evil; ",
"I'm ignoring it and supplying my own.");
$fname = $self->output_filename($head);
}
}
$self->debug("planning to use '$fname'");
#untaint dir and fname
$self->debug("it is our own");
$fname = ($fname =~ m/^([ \w_.:%-]+)$/ig) ? $1 : $self->output_filename($head);
### Resolve collisions and return final path:
return $self->find_unused_path($dir, $fname);
};
}
use MIME::Entity;
use MIME::Head;
use File::MMagic;
use Convert::TNEF;
my $parser;
my $ent;
my $tmpdir='/var/spool/qpsmtpd';
my $count=0;
my $foundtnef=0;
my (@attachments, @blocked, @tnefs);
sub register {
my ($self, $qp, %arg) = @_;
$self->register_hook("data_post", "tnef2mime");
}
sub hasMessageClassProperty {
my $self = shift;
my $data = $self->data("Attachment");
return 0 unless $data;
return index( $data, pack( "H*", "8008" ) ) >= 0;
}
# for future use
sub kill_part ($)
{
my $part=$_;
#my $path = defined $part->bodyhandle ? $part->bodyhandle->path : "";
#my $filename = $part->head->recommended_filename || "";
return $part;
}
sub keep_part ($$)
{
my ($self,$part)=@_;
my $mm = new File::MMagic;
# when a ms-tnef attachment was sent uuencoded, its MIME type becomes application/octet-stream
# after the conversion. Therefore all application/octet-stream attachments are assumed to
# be a ms-tnef
my $path = $part->bodyhandle ? $part->bodyhandle->path : "";
if( $part->mime_type =~ /ms-tnef/i || $part->mime_type =~ /application\/octet-stream/i )
{
# convert tnef attachments and write to files
my $tnef = Convert::TNEF->read_ent($part,{output_dir=>$tmpdir,output_to_core=>"NONE"});
# if $tnef is undefined here, the application/octet-stream was not a ms-tnef and we are done.
return 1 if( ! defined $tnef );
my $keep_tnef=0;
for ($tnef->attachments)
{
next if !defined $_->datahandle;
if( hasMessageClassProperty($_) ) # Outlook MAPI object
{
$keep_tnef++;
$self->log(LOGWARN, sprintf "Outlook MAPI object #%i: %s", $keep_tnef, $_->longname);
next;
}
my $mimetype = $mm->checktype_filename( $_->datahandle->path );
$attachments[$count] = MIME::Entity->build(
Path=>$_->datahandle->path,
Filename=>$_->longname,
Encoding=>"base64",
Type=>$mimetype );
$self->log(LOGWARN,
sprintf "File attachment #%i: %s (%s, %ld bytes)", $count+1, $_->longname, $mimetype, $_->size );
$count++;
}
if( $keep_tnef )
{
$attachments[$count++] = $part;
$self->log(LOGWARN, "Original TNEF file attached." );
}
push( @tnefs, $tnef ); # remind for cleanup
$foundtnef=1;
return 0;
}
return 1;
}
sub tnef2mime ( $$ )
{
my ($self, $transaction) = @_;
# new Parser Object
$parser = new MIME::Parser;
# if you want to debug the Parser :
#use MIME::Tools; MIME::Tools->debugging(1);
# temp output directory
$parser->output_under( $tmpdir );
$parser->extract_uuencode(1);
#untainted filename
$transaction->body_filename() =~ /^([:\-\/\w]+)\z/ or die "Disallowed characters in filename ".$transaction->body_filename();
my $bdfilename = $1;
# read message body
open BFN, "<", $bdfilename ;#$transaction->body_filename();
$ent = $parser->parse(\*BFN);
my @keep = grep { keep_part($self, $_) } $ent->parts; # @keep now holds all non-tnef attachments
close BFN;
my $founduu = $ent->parts && !$transaction->header->get('MIME-Version');
if( $foundtnef || $founduu )
{
my @allatt;
@allatt = map { kill_part($_) } ( @keep, @attachments );
$ent->parts(\@allatt);
# if message is a multipart type, but has MIME version tag, then add
# MIME version. PHP imap_fetchstructure() depends on that!
my $xac;
if( $founduu )
{
$transaction->header->add('MIME-Version', "1.0" );
$xac = "UUENCODE -> MIME";
$self->log(LOGDEBUG, "uuencoded attachment converted to MIME" );
}
# delete the X-MS-TNEF-Correlator header line
if( $foundtnef )
{
$xac .= ( defined $xac ? ", " : "" ) . "MS-TNEF -> MIME";
$transaction->header->delete('X-MS-TNEF-Correlator' );
}
# add own X header
if( defined $xac )
{
$transaction->header->add('X-TNEF2MIME-Plugin', $xac );
}
# write converted message body
open BFN, ">" , $bdfilename;#$transaction->body_filename();
$ent->print(\*BFN);
close BFN;
}
# cleaning up
for( my $i=0; $i<@tnefs; $i++ )
{
$tnefs[$i]->purge();
}
#untainted filename
$parser->output_dir =~ /^([:\-\/\w]+)\z/ or die "Disallowed characters in output dir ".$parser->output_dir;
my $output_dir = $1;
opendir( DIR, $output_dir ) or die "Could not open temporary output dir $output_dir: $!\n";
while( defined( my $file = readdir( DIR ) ) )
{
next if $file =~ /^\.\.?$/;
$file =~ s/(^.*$)//;
$file = $1;
unlink( "$output_dir/$file" );
}
closedir( DIR );
rmdir( $output_dir );
return DECLINED;
}

186
root/usr/share/qpsmtpd/plugins/virus/pattern_filter Normal file
View File

@@ -0,0 +1,186 @@
=head1 NAME
pattern_filter
=head1 DESCRIPTION
pattern_filter blocks executable (and other) attachments by matching
each line in a message against a set of known signatures. If a match is
found, the email is denied.
Signatures are stored one per line in signature files in the qpsmtpd
config directory. pattern_filter currently supports
'signature_exe' and 'signature_zip' files.
This version is heavily based on Gavin Carr's exe_filter, but implemented
so as not to care about MIME boundaries. This traps mangled MIME mail
which is still interpreted by some mail clients. However, bare lines
which happen to contain the pattern will match.
This approach has the added advantage of reading the spool file directly,
rather than reassembling the message in memory for Email::MIME to parse.
=head1 CONFIG
The following parameters can be passed to pattern_filter, or set in a
'pattern_filter' config file.
=over 4
=item check <suffixes>
where <suffixes> is a comma-separated list of suffixes to check e.g.
check exe,zip
A corresponding 'signature_<suffix>' file should exist for each supplied
suffix.
Default: 'check patterns'.
Note: this argument used to be called 'deny', which is now deprecated but
still functional.
=item action <action>
The action to take when a signature match is found. Valid values are 'deny'
(the default), to DENY the mail, and 'note', to record a transaction note
for some later plugin (and then DECLINE). If action is 'note', the default
note name is 'virus_score', with a default value of 1. These defaults can
be modified using an extended note syntax - 'note:NAME=VALUE' e.g.
action note:virus_score=1 # default settings
action note:pattern_filter=virus_found # random example
Numeric note values are accumulated, not replaced.
Default: 'action deny'.
=back
The following parameter can be passed to pattern_filter in
config/plugins (but not set via a config file):
=over 4
=item per_recipient 1
Allow per-recipient configs to be used (using the per_user_config plugin).
Default: 0.
=back
=head1 BUGS AND LIMITATIONS
pattern_filter is a simple pattern - it does not unpack and scan
archives for executables like a full-blown virus scanner. Likewise, zip
filtering blocks *all* zip files, not just those that contain a virus. You
should use a proper virus scanner if that's what you need.
Because pattern_filter is a post_data plugin, it cannot handle different
configurations in per_recipient mode. This means that if you want to use
per_recipient configurations, you should also enforce that only compatible
recipients occur in a single mail (e.g. using a plugin like
denysoft_multi_rcpt).
=head1 AUTHOR
Written by Gordon Rowell <gordonr@gormand.com.au>, heavily based on
the following:
Written by Gavin Carr <gavin@openfusion.com.au>, inspired by Russ Nelson's
viruscan patch to qmail-smtpd
(http://www.qmail.org/qmail-smtpd-viruscan-1.2.patch).
=head1 COPYRIGHT
Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
Copyright 2004 Gavin Carr <gavin@openfusion.com.au>
Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
This software is free software and may be distributed under the same
terms as Perl itself.
=cut
# use Email::MIME;
#my $VERSION = 0.04;
my $VERSION = 0.01;
my %DEFAULTS = ( deny => 'patterns', action => 'deny', per_recipient => 0 );
sub register {
my ($self, $qp, %arg) = @_;
$self->{_config_defaults} = { %DEFAULTS, %arg };
$self->register_hook("rcpt", "setup_config") if $arg{per_recipient};
$self->register_hook("data_post", "pattern_filter");
}
sub setup_config {
my ($self, $transaction, $rcpt) = @_;
# Setup only once
return DECLINED if $self->{_config};
return DECLINED
unless ref $self->{_config_defaults} eq 'HASH';
# Setup config from defaults and per_recipient pattern_filter config
my @config = $self->qp->config('pattern_filter', { rcpt => $rcpt });
$self->{_config} = {
%{$self->{_config_defaults}},
rcpt => $rcpt,
@config ? map { split /\s+/, $_, 2 } @config : ()
};
return DECLINED;
}
sub pattern_filter {
my ($self, $transaction) = @_;
# Setup config parameters if not already done
my $config = $self->{_config};
unless ($config) {
my @config = $self->qp->config('pattern_filter');
$config = {
%{$self->{_config_defaults}},
@config ? map { split /\s+/, $_, 2 } @config : ()
};
};
$config->{check} ||= $config->{deny};
return DECLINED unless $config->{check};
# Load signatures
my @signatures = ();
my $config_arg = $config->{rcpt} ? { rcpt => $config->{rcpt} } : {};
for my $suffix (split /\s*,\s*/, $config->{check}) {
my @sig = $self->qp->config("signatures_$suffix", $config_arg);
$self->log(3, "warning - no signatures_$suffix loaded") unless @sig;
push @signatures, @sig if @sig;
}
return DECLINED unless @signatures;
my $patterns = join("|", @signatures);
my $pat = qr{ ^($patterns) }xmso;
$transaction->body_resetpos;
my ($status,$msg);
while ($_ = $transaction->body_getline)
{
if ( $_ =~ m{$pat} )
{
my $match = $1;
$self->log(6, "the following line matched '$match':\n$_");
return (DENY, "We don't accept email with executable content [$match].");
}
}
return DECLINED;
}
# arch-tag: 3fc272f2-9d52-42d4-893b-032b529ec71d