Attachment #5011 for bug #6698

View | Details | Raw Unified | Return to bug 6698
Collapse All | Expand All




# The ASF licenses this file to you under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at:
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.

# limitations under the License.
# </@LICENSE>

# Changes since SpamAssassin 3.3.2:
#   support for DCC learning.  See dcc_learn_score.
#   deal with orphan dccifd sockets
#   use `cdcc -q` to not stall waiting to find a DCC server when deciding
#     whether DCC checks are enabled
#   use dccproc -Q or dccifd query if a pre-existing X-DCC header shows
#     the message has already been reported
#   dccproc now uses -w /var/dcc/whiteclnt so it acts more like dccifd
#   warn about the use of ancient versions of dccproc and dccifd
#   turn off dccifd greylisting
#   query instead of reporting mail messages that contain X-DCC headers and
#     and so has probably already been reported
#   try harder to find dccproc and cdcc when not explicitly configured
#	Rhyolite Software DCC 2.3.140-1.4 $Revision$

=head1 NAME

Mail::SpamAssassin::Plugin::DCC - perform DCC check of messages

=head1 SYNOPSIS

  loadplugin Mail::SpamAssassin::Plugin::DCC

  full DCC_CHECK	eval:check_dcc()
  full DCC_CHECK_50_79	eval:check_dcc_reputation_range('50','79')

=head1 DESCRIPTION

The DCC or Distributed Checksum Clearinghouse is a system of servers
collecting and counting checksums of millions of mail messages.
The counts can be used by SpamAssassin to detect and filter spam.
reject or filter spam.

See http://www.dcc-servers.net/dcc/ for more information about DCC.
DCC checksums are fuzzy and ignore aspects of messages.  The fuzzy
checksums are changed as spam evolves.

Note that DCC is disabled by default in C<v310.pre> because its use requires
software that is not distributed with SpamAssassin and that has license
restrictions for certain commercial uses.
See the DCC license at http://www.dcc-servers.net/dcc/LICENSE for details.

Enable it by uncommenting the "loadplugin Mail::SpamAssassin::Plugin::DCC"
confdir/v310.pre or by adding this line to your local.pre.  It might also
be necessary to install a DCC package, port, rpm, or equivalent from your
operating system distributor or a tarball from the primary DCC source
at http://www.dcc-servers.net/dcc/#download
See also http://www.dcc-servers.net/dcc/INSTALL.html

=head1 TAGS

The following tags are added to the set, available for use in reports,
header fields, other plugins, etc.:

  _DCCB_    DCC server ID in X-DCC-*-Metrics header field name
  _DCCR_    X-DCC-*-Metrics header field body
  _DCCREP_  DCC Reputation or percent bulk mail (0..100) from
	      commercial DCC software

Tag _DCCREP_ provides a nonempty value only with commercial DCC systems.
This is the percentage of spam vs. ham sent from the first untrusted relay.

=cut

package Mail::SpamAssassin::Plugin::DCC;

use vars qw(@ISA);
@ISA = qw(Mail::SpamAssassin::Plugin);

use vars qw($have_inet6);

sub new {
  my $class = shift;
  my $mailsaobject = shift;


  # are network tests enabled?
  if ($mailsaobject->{local_tests_only}) {
    $self->{use_dcc} = 0;
    dbg("dcc: local tests only, disabling DCC");
  }
  else {


=item dcc_fuz2_max NUMBER

Sets how often a message's body/fuz1/fuz2 checksum must have been reported
to the DCC server before SpamAssassin will consider the DCC check hit.
C<999999> is DCC's MANY count.

As nearly all DCC clients are auto-reporting these checksums, you should set
this to a relatively high value, e.g. C<999999> (this is DCC's MANY count).

The default is C<999999> for all these options.

=item dcc_rep_percent NUMBER

Only the commercial DCC software provides DCC Reputations.  A DCC Reputation
is the percentage of bulk mail received from the last untrusted relay in the
path taken by a mail message as measured by all commercial DCC installations.
See http://www.rhyolite.com/dcc/reputations.html
You C<must> whitelist your trusted relays or MX servers with MX or
MXDCC lines in /var/dcc/whiteclnt as described in the main DCC man page
to avoid seeing your own MX servers as sources of bulk mail.
See http://www.dcc-servers.net/dcc/dcc-tree/dcc.html#White-and-Blacklists
The default is C<90>.

=cut


=item dcc_home STRING

This option tells SpamAssassin where to find the dcc homedir.
If not specified, try to use the locally configured directory
from the C<cdcc homedir> command.
Try /var/dcc if that command fails.
C<dcc_home/bin> for dcc client instead of relying on SpamAssassin to find it
in the current PATH.  If it isn't found there, it will look in the current
PATH. If a C<dccifd> socket is found in C<dcc_home> or specified explicitly,
it will use that interface instead of C<dccproc>.

=cut


      $value = untaint_file_path($value);
      my $stat_errn = stat($value) ? 0 : 0+$!;
      if ($stat_errn != 0 || !-d _) {
	my $msg = $stat_errn == ENOENT ? "does not exist"
		  : !-d _ ? "is not a directory" : "not accessible: $!";
	info("config: dcc_home \"$value\" $msg");
	return $Mail::SpamAssassin::Conf::INVALID_VALUE;
      }


=item dcc_dccifd_path STRING

This option tells SpamAssassin where to find the dccifd socket instead
of a local Unix socket named C<dccifd> in the C<dcc_home> directory.
If a socket is specified or found, use it instead of C<dccproc>.
a Unix socket name (absolute path), or an INET socket specification in a form
C<[host]:port> or C<host:port>, where a host can be an IPv4 or IPv6 address
or a host name, and port is a TCP port number. In case of an IPv6 address the
brackets are required syntax. If a C<dccifd> socket is found, the plugin will
use it instead of C<dccproc>.

If specifed, C<dcc_dccifd_path> is the absolute path of local Unix socket
or an INET socket specified as C<[Host]:Port> or C<Host:Port>.
Host can be an IPv4 or IPv6 address or a host name
Port is a TCP port number. The brackets are required for an IPv6 address.

The default is C<undef>.

=cut

  push (@cmds, {

    type => $Mail::SpamAssassin::Conf::CONF_TYPE_STRING,
    code => sub {
      my ($self, $key, $value, $line) = @_;

      if (!defined $value || $value eq '') {
      undef $self->{dcc_dccifd_host};
      undef $self->{dcc_dccifd_port};
      undef $self->{dcc_dccifd_socket};
      local($1,$2,$3);
      if ($value eq '') {
	return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
      } elsif ($value =~ m{^ (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) \z}sx) {
        # "[host]:port" or "host:port", where a host can be an IPv4 or IPv6
        # address or a host name, and port is a TCP port number or service name
        my $host = defined $1 ? $1 : $2;
        my $port = $3;
        $self->{dcc_dccifd_host} = untaint_var($host);
        $self->{dcc_dccifd_port} = untaint_var($port);
        dbg("config: dcc_dccifd_path set to [%s]:%s", $host,$port);
      } else {  # assume a unix socket
        if ($value !~ m{^/}) {
          info("config: dcc_dccifd_path should be an absolute socket path");
        # return $Mail::SpamAssassin::Conf::INVALID_VALUE;  # abort or accept?
        }
        $value = untaint_file_path($value);
      # test disabled, dccifd may not yet be running at spamd startup time
      # if (!-S $value) {
      #   info("config: dcc_dccifd_path '$value' isn't a local socket");
      #   return $Mail::SpamAssassin::Conf::INVALID_VALUE;
      # }
        $self->{dcc_dccifd_socket} = $value;
        dbg("config: dcc_dccifd_path set to local socket %s", $value);
      }

      local($1,$2,$3);
      if ($value =~ m{^ (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) \z}sx) {
	my $host = untaint_var(defined $1 ? $1 : $2);
	my $port = untaint_var($3);
	if (!$host) {
	  info("config: missing or bad host name in dcc_dccifd_path '$value'");
	  return $Mail::SpamAssassin::Conf::INVALID_VALUE;
	}
	if (!$port || $port !~ /^\d+\z/ || $port < 1 || $port > 65535) {
	  info("config: bad TCP port number in dcc_dccifd_path '$value'");
	  return $Mail::SpamAssassin::Conf::INVALID_VALUE;
	}

	$self->{dcc_dccifd_host} = $host;
	$self->{dcc_dccifd_port} = $port;
	if ($host !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/) {
	  # remember to try IPv6 if we can with a host name or non-IPv4 address
	  $self->{dcc_dccifd_IPv6} = eval { require IO::Socket::INET6 };
	}
	dbg("config: dcc_dccifd_path set to [%s]:%s", $host, $port);

      } else {
	# assume a unix socket
	if ($value !~ m{^/}) {
	  info("config: dcc_dccifd_path '$value' is not an absolute path");
	  # return $Mail::SpamAssassin::Conf::INVALID_VALUE;  # abort or accept?
	}
	$value = untaint_file_path($value);

	$self->{dcc_dccifd_socket} = $value;
	dbg("config: dcc_dccifd_path set to local socket %s", $value);
	dbg("dcc: dcc_dccifd_path set to local socket %s", $value);
      }

      $self->{dcc_dccifd_path_raw} = $value;
    }
  });

=item dcc_path STRING

Where to find the C<dccproc> client program instead of relying on SpamAssassin
to find it in the current PATH or C<dcc_home/bin>. This must often be set,
because the current PATH is cleared by I<taint mode> in the Perl interpreter,
use this, as the current PATH will have been cleared.

If a C<dccifd> socket is found in C<dcc_home> or specified explicitly
with C<dcc_dccifd_path>, use the C<dccifd(8)> interface instead of C<dccproc>.

The default is C<undef>.


=cut

  push (@cmds, {

      }
      $value = untaint_file_path($value);
      if (!-x $value) {
	info("config: dcc_path '$value' is not executable");
	return $Mail::SpamAssassin::Conf::INVALID_VALUE;
      }



=item dcc_options options

Specify additional options to the dccproc(8) command.  Only
characters in the range [0-9A-Za-z ,._/-] are allowed for security reasons.

The default is C<undef>.

    code => sub {
      my ($self, $key, $value, $line) = @_;
      if ($value !~ m{^([0-9A-Za-z ,._/-]+)$}) {
	info("config: dcc_options '$value' contains impermissible characters");
	return $Mail::SpamAssassin::Conf::INVALID_VALUE;
      }
      $self->{dcc_options} = $1;


=item dccifd_options options

Specify additional options to send to the dccifd daemon with
the ASCII protocol described on the dccifd(8) man page.
Only characters in the range [0-9A-Za-z ,._/-] are allowed for security reasons.

The default is C<undef>.


    code => sub {
      my ($self, $key, $value, $line) = @_;
      if ($value !~ m{^([0-9A-Za-z ,._/-]+)$}) {
	info("config: dccifd_options '$value' contains impermissible characters");
	return $Mail::SpamAssassin::Conf::INVALID_VALUE;
      }
      $self->{dccifd_options} = $1;
    }
  });

=item dcc_learn_score n		(default: undef)

Report messages with total scores this much larger than the
SpamAssassin spam threshold to DCC as spam.

=cut

  push (@cmds, {
    setting => 'dcc_learn_score',
    is_admin => 1,
    default => undef,
    type => $Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC,
  });

  $conf->{parser}->register_commands(\@cmds);
}




sub ck_dir {
  my ($self, $dir, $tgt, $src) = @_;

  $dir = untaint_file_path($dir);
  if (!stat($dir)) {
    my $dir_errno = 0+$!;
    if ($dir_errno == ENOENT) {
      dbg("dcc: $tgt $dir from $src does not exist");
    } else {
      dbg("dcc: $tgt $dir from $src is not accessible: $!");
    }
    return;
  }
  if (!-d _) {
    dbg("dcc: $tgt $dir from $src is not a directory");
    return;
  }

  $self->{main}->{conf}->{$tgt} = $dir;
  dbg("dcc: use '$tgt $dir' from $src");
}

sub find_dcc_home {
  my ($self) = @_;
  my $dcc_libexec;

  # just once
  return if defined $self->{dcc_version};
  $self->{dcc_version} = '?';

  my $conf = $self->{main}->{conf};
  return if !$conf->{use_dcc};

  my $dcchome = $conf->{dcc_home} || '';

  # Get the DCC software version for talking to dccifd and formating the
  # dccifd options and the built-in DCC homedir.  Use -q to prevent delays.
  my $cdcc_home;
  my $cdcc = $self->dcc_pgm_path('cdcc');
  my $cmd = '-qV homedir libexecdir';
  if ($cdcc && open(CDCC, "$cdcc $cmd 2>&1 |")) {
    my $cdcc_output = do { local $/ = undef; <CDCC> };
    close CDCC;

    $cdcc_output =~ s/\n/ /g;		# everything in 1 line for debugging
    dbg("dcc: `%s %s` reports '%s'", $cdcc, $cmd, $cdcc_output);
    $self->{dcc_version} = ($cdcc_output =~ /^(\d+\.\d+\.\d+)/) ? $1 : '';
    $cdcc_home = ($cdcc_output =~ /\s+homedir=(\S+)/) ? $1 : '';
    if ($cdcc_output =~ /\s+libexecdir=(\S+)/) {
      $self->ck_dir($1, 'dcc_libexec', 'cdcc');
    }
  }

  # without a home, try the homedir from cdcc
  if (!$conf->{dcc_home} && $cdcc_home) {
    $self->ck_dir($cdcc_home, 'dcc_home', 'cdcc');
  }
  # finally fall back to /var/dcc
  if (!$conf->{dcc_home}) {
    $self->ck_dir($conf->{dcc_home} = '/var/dcc', 'dcc_home', 'default')
  }

  # fall back to $conf->{dcc_home}/libexec or /var/dcc/libexec for dccsight
  if (!$conf->{dcc_libexec}) {
    $self->ck_dir($conf->{dcc_home} . '/libexec', 'dcc_libexec', 'dcc_home');
  }
  if (!$conf->{dcc_libexec}) {
    $self->ck_dir('/var/dcc/libexec', 'dcc_libexec', 'dcc_home');
  }

  # format options for dccifd
  my $opts = ($conf->{dccifd_options} || '') . "\n";
  if ($self->{dcc_version} =~ /\d+\.(\d+)\.(\d+)$/ &&
      ($1 < 3 || ($1 == 3 && $2 < 123))) {
    if ($1 < 3 || ($1 == 3 && $2 < 50)) {
      info("dcc: DCC version $self->{dcc_version} is years old, ".
           "obsolete, and likely to cause problems.  ".
           "See http://www.dcc-servers.net/dcc/old-versions.html");
    }
    $self->{dccifd_lookup_options} = "header " . $opts;
    $self->{dccifd_report_options} = "header spam " . $opts;
  } else {
    # dccifd after version 1.2.123 understands "cksums" and "no-grey"
    $self->{dccifd_lookup_options} = "cksums grey-off " . $opts;
    $self->{dccifd_report_options} = "header spam grey-off " . $opts;
  }
}
      $dcchome = untaint_var($cdcc_home);
    }

sub dcc_pgm_path {
  my ($self, $pgm) = @_;
  my $pgmpath;
  my $conf = $self->{main}->{conf};
        # no such file
      } elsif ($var_dcc_errno != 0) {
        dbg("dcc: dcc_home not set and dcc default homedir /var/dcc ".
            "is not accessible: $!");
      } elsif (!-d _) {
        dbg("dcc: dcc_home not set and dcc default homedir /var/dcc ".
            "is not a directory");
      } else {  # ok
        dbg("dcc: dcc_home not set but dcc default homedir /var/dcc exists, ".
            "using it");
        $dcchome = '/var/dcc';
      }
    }

  if ($pgmpath = $conf->{dcc_path}) {
    # accept explicit setting for dccproc
    return $pgmpath if $pgm eq 'dccproc';
    # try adapting it for cdcc and everything else
    if ($pgmpath =~ s/[^\/]+$/$pgm/) {
      $pgmpath = untaint_file_path($pgmpath);
      return $pgmpath if (-x $pgmpath);
    }
  }

  $pgmpath = Mail::SpamAssassin::Util::find_executable_in_env_path($pgm);
  return $pgmpath if $pgmpath;

  # we might be looking for cdcc for $self->find_dcc_home()
  my $home = $conf->{dcc_home} || '/var/dcc';

  $pgmpath = untaint_file_path($conf->{dcc_home} . "/bin/" . $pgm);
  return ($pgmpath) if (-x $pgmpath);

  if ($conf->{dcc_libexec}) {
    $pgmpath = $conf->{dcc_libexec} . "/" . $pgm;
    return ($pgmpath) if (-x $pgmpath);
  }

  # desperate last attempts
  $pgmpath = '/usr/local/bin/' . $pgm;
  return $pgmpath if (-x $pgmpath);
  $pgmpath = '/var/dcc/' . $pgm;
  return $pgmpath if (-x $pgmpath);

  return undef;
}

sub is_dccifd_available {
  my ($self) = @_;

  my $conf = $self->{main}->{conf};
  $self->{dccifd_available} = 0;

  # dccifd remains available until it breaks
  return $self->{dccifd_available} if $self->{dccifd_available};

  # deal with configured INET socket
  if (defined $conf->{dcc_dccifd_host}) {
    dbg("dcc: dccifd is available via INET socket [%s]:%s",
	$conf->{dcc_dccifd_host}, $conf->{dcc_dccifd_port});
    return ($self->{dccifd_available} = 1);
  }

  # the first time here, compute a default local socket based on DCC home
  # from self->find_dcc_home() called elsewhere
  my $sockpath = $conf->{dcc_dccifd_socket};
  if (!$sockpath) {
      if ($conf->{dcc_dccifd_path_raw}) {
	$sockpath = $conf->{dcc_dccifd_path_raw};
      } else {
	$sockpath = "$conf->{dcc_home}/dccifd";
      }
      $conf->{dcc_dccifd_socket} = $sockpath;
      dbg("dcc: dccifd default local socket chosen: %s", $sockpath);
    }
    if (defined $sockpath && -S $sockpath && -w _ && -r _) {
      $self->{dccifd_available} = 1;
    } elsif (!defined $conf->{dcc_dccifd_path_raw}) {
      dbg("dcc: dccifd is not available: no r/w dccifd socket found");
    } else {
      dbg("dcc: dccifd is not available: no r/w dccifd socket found: %s",
          $conf->{dcc_dccifd_path_raw});
    }
  }

  # check the socket every time because it can appear and disappear
  return ($self->{dccifd_available} = 1) if (-S $sockpath && -w _ && -r _);

  dbg("dcc: dccifd is not available; no r/w socket at %s", $sockpath);
  return ($self->{dccifd_available} = 0);
}

sub is_dccproc_available {
  my ($self) = @_;
  my $conf = $self->{main}->{conf};

  # dccproc remains (un)available so check only once
  return $self->{dccproc_available} if  defined $self->{dccproc_available};

  my $dccproc = $conf->{dcc_path};
  if (!$dccproc) {
    $dccproc = $self->dcc_pgm_path('dccproc');
    $conf->{dcc_path} = $dccproc;
    if (!$dccproc || ! -x $dccproc) {
      dbg("dcc: dccproc is not available: no dccproc executable found");
      return ($self->{dccproc_available} = 0);
    }
  }
  my $dcchome = $conf->{dcc_home} || '';
  my $dccproc = $conf->{dcc_path} || '';

  dbg("dcc: %s is available", $conf->{dcc_path});
  return ($self->{dccproc_available} = 1);
  }
  if ($dccproc eq '') {
    $dccproc = Mail::SpamAssassin::Util::find_executable_in_env_path('dccproc');
  }

  unless (defined $dccproc && $dccproc ne '' && -x $dccproc) {
    dbg("dcc: dccproc is not available: no dccproc executable found");
    return 0;
  }

  # remember any found dccproc
  $conf->{dcc_path} = $dccproc;

  dbg("dcc: dccproc is available: %s", $conf->{dcc_path});
  $self->{dccproc_available} = 1;
  return 1;
}

sub dccifd_connect {
  my($self, $tag) = @_;
  my $conf = $self->{main}->{conf};
  my $sockpath = $conf->{dcc_dccifd_socket};
  my $host = $conf->{dcc_dccifd_host};
  my $port = $conf->{dcc_dccifd_port};
  my $sock;

  if (defined $sockpath) {
    $sock = IO::Socket::UNIX->new(Type => SOCK_STREAM, Peer => $sockpath);
    if ($sock) {
      dbg("$tag connected to local socket %s", $sockpath);
      return $sock;
  } elsif (defined $host) {
    my $specified_path = $conf->{dcc_dccifd_path_raw};
    if ($host eq '') {
      die "dcc: empty host specification: $specified_path\n";
    }
    $self->{dccifd_available} = 0;
    info("$tag failed to connect to local socket $sockpath");
    return $sock
    my $is_inet4 = $host =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/;
    if ($is_inet4) {  # inet4 socket (IPv4 address)
      dbg("dcc: connecting to inet4 socket [%s]:%s", $host,$port);
      $sock = IO::Socket::INET->new(
                Proto => 'tcp', PeerAddr => $host, PeerPort => $port);
    } else {
      if (!defined $have_inet6) {
        $have_inet6 = eval { require IO::Socket::INET6 };
        $have_inet6 = 0  if !defined $have_inet6;
      }
      if (!$have_inet6) {  # fallback to an inet4 socket (IPv4)
        dbg("dcc: connecting(2) to inet4 socket [%s]:%s", $host,$port);
        $sock = IO::Socket::INET->new(
                  Proto => 'tcp', PeerAddr => $host, PeerPort => $port);
      } else {  # inet6 socket (IPv6) or a host name
        dbg("dcc: connecting to inet6 socket [%s]:%s", $host,$port);
        $sock = IO::Socket::INET6->new(
                  Proto => 'tcp', PeerAddr => $host, PeerPort => $port);
      }
    }
    $sock or die "dcc: failed to connect to [$host]:$port : $!\n";
  } else {
    die "dcc: dccifd socket not provided: $conf->{dcc_dccifd_path_raw}\n";
  }

  # must be TCP/IP
  my $host = $conf->{dcc_dccifd_host};
  my $port = $conf->{dcc_dccifd_port};

  if ($conf->{dcc_dccifd_IPv6}) {
    # try IPv6 if we can with a host name or non-IPv4 address
    dbg("$tag connecting to inet6 socket [%s]:%s", $host,$port);
    $sock = IO::Socket::INET6->new(
		  Proto => 'tcp', PeerAddr => $host, PeerPort => $port);
    # fall back to IPv4 if that failed
  }
  if (!$sock) {
    dbg("$tag connecting to inet4 socket [%s]:%s", $host, $port);
    $sock = IO::Socket::INET->new(
		Proto => 'tcp', PeerAddr => $host, PeerPort => $port);
  }

  info("failed to connect to [$host]:$port : $!") if !$sock;
  return $sock;
}

# check for dccifd every time in case enough uses of dccproc starts dccifd
sub get_dcc_interface {
  my ($self) = @_;
  my $conf = $self->{main}->{conf};

  if (!$conf->{use_dcc}) {
    $self->{dcc_disabled} = 1;
    return;
  }

  $self->find_dcc_home();
  if (!$self->is_dccifd_available() && !$self->is_dccproc_available()) {
    dbg("dcc: dccifd and dccproc are not available");
  else {
    dbg("dcc: dccifd and dccproc are not available, disabling DCC");
    $self->{dcc_interface} = "none";
    $self->{dcc_disabled} = 1;
  }

  $self->{dcc_disabled} = 0;
}

sub dcc_query {
  my ($self, $permsgstatus, $fulltext) = @_;

  $permsgstatus->{dcc_checked} = 1;

  if (!$self->{main}->{conf}->{use_dcc}) {
    dbg("dcc: DCC is not available: use_dcc is 0");
    return;
  }

  # initialize valid tags
  $permsgstatus->{tag_data}->{DCCB} = "";
  $permsgstatus->{tag_data}->{DCCR} = "";
  $permsgstatus->{tag_data}->{DCCREP} = "";

  if ($$fulltext eq '') {
    dbg("dcc: empty message; skipping dcc check");
  if ($permsgstatus->get('ALL') =~
      /^(X-DCC-([^:]{1,80})?-?Metrics:.*bulk.*)$/m) {
    $permsgstatus->{dcc_response} = $1;
    return;
  }

  if ($permsgstatus->get('ALL') =~ /^(X-DCC-.*-Metrics:.*)$/m) {
    $permsgstatus->{dcc_raw_x_dcc} = $1;
    # short-circuit if there is already a X-DCC header with value of
    # "bulk" from an upstream DCC check
    # require "bulk" because then at least one body checksum will be "many"
    # and so we know the X-DCC header is not forged by spammers
    return if $permsgstatus->{dcc_raw_x_dcc} =~ / bulk /;
  }

  my $timer = $self->{main}->time_method("check_dcc");

  $self->get_dcc_interface();
  return if $self->{dcc_disabled};

  my $envelope = $permsgstatus->{relays_external}->[0];
  ($permsgstatus->{dcc_raw_x_dcc},
   $permsgstatus->{dcc_cksums}) = $self->ask_dcc("dcc:", $permsgstatus,
						 $fulltext, $envelope);
  } elsif ($$full eq '') {
    dbg("dcc: empty message, skipping dcc check");
    $result = 0;
  } elsif ($self->{dccifd_available}) {
    my $client = $permsgstatus->{relays_external}->[0]->{ip};
    my $clientname = $permsgstatus->{relays_external}->[0]->{rdns};
    my $helo = $permsgstatus->{relays_external}->[0]->{helo} || "";
    if ($client) {
      $client = $client . "\r" . $clientname  if $clientname;
    } else {
      $client = "0.0.0.0";
    }
    $self->dccifd_lookup($permsgstatus, $full, $client, $clientname, $helo);
  } else {
    my $client = $permsgstatus->{relays_external}->[0]->{ip};
    $self->dccproc_lookup($permsgstatus, $full, $client);
  }
}

sub check_dcc {


  $self->dcc_query($permsgstatus, $full)  if !$permsgstatus->{dcc_checked};

  my $x_dcc = $permsgstatus->{dcc_raw_x_dcc};
  return 0  if !defined $x_dcc || $x_dcc eq '';

  if ($x_dcc =~ /^X-DCC-(.*)-Metrics: (.*)$/) {
  if ($response =~ /^X-DCC-(.*)-Metrics: (.*)$/) {
    $permsgstatus->set_tag('DCCB', $1);
    $permsgstatus->set_tag('DCCR', $2);
  }
  $x_dcc =~ s/many/999999/ig;
  $x_dcc =~ s/ok\d?/0/ig;

  my %count = (body => 0, fuz1 => 0, fuz2 => 0, rep => 0);
  if ($x_dcc =~ /\bBody=(\d+)/) {
    $count{body} = $1+0;
  }
  if ($x_dcc =~ /\bFuz1=(\d+)/) {
    $count{fuz1} = $1+0;
  }
  if ($x_dcc =~ /\bFuz2=(\d+)/) {
    $count{fuz2} = $1+0;
  }
  if ($x_dcc =~ /\brep=(\d+)/) {
    $count{rep}  = $1+0;
  }
  if ($count{body} >= $conf->{dcc_body_max} ||

      $count{rep}  >= $conf->{dcc_rep_percent})
  {
    dbg(sprintf("dcc: listed: BODY=%s/%s FUZ1=%s/%s FUZ2=%s/%s REP=%s/%s",
		map { defined $_ ? $_ : 'undef' } (
		  $count{body}, $conf->{dcc_body_max},
		  $count{fuz1}, $conf->{dcc_fuz1_max},
		  $count{fuz2}, $conf->{dcc_fuz2_max},
		  $count{rep},  $conf->{dcc_rep_percent})
		));
    return 1;
  }
  return 0;
}

sub check_dcc_reputation_range {
  my ($self, $permsgstatus, $fulltext, $min, $max) = @_;
  $self->dcc_query($permsgstatus, $full)  if !$permsgstatus->{dcc_checked};

  # this is called several times per message, so parse the X-DCC header once
  my $dcc_rep = $permsgstatus->{dcc_rep};
  if (!defined $dcc_rep) {
    $self->dcc_query($permsgstatus, $fulltext)  if !$permsgstatus->{dcc_checked};
    my $x_dcc = $permsgstatus->{dcc_raw_x_dcc};
    if (defined $x_dcc && $x_dcc =~ /\brep=(\d+)/) {
      $dcc_rep = $1+0;
      $permsgstatus->set_tag('DCCREP', $dcc_rep);
    } else {
      $dcc_rep = -1;
    }
    $permsgstatus->{dcc_rep} = $dcc_rep;
  }

  # no X-DCC header or no reputation in the X-DCC header, perhaps for lack
  # of data in the DCC Reputation server
  return 0 if $dcc_rep < 0;

  # cover the entire range of reputations if not told otherwise
  $min = 0   if !defined $min;
  $max = 100 if !defined $max;

  my $result = $dcc_rep >= $min && $dcc_rep <= $max ? 1 : 0;
  dbg("dcc: dcc_rep %s, min %s, max %s => result=%s",
      $dcc_rep, $min, $max, $result?'YES':'no');
  return $result;
}

# get the X-DCC header line and save the checksums from dccifd or dccproc
sub parse_dcc_response {
  my ($self, $resp) = @_;
  my ($raw_x_dcc, $cksums);

  # The first line is the header we want.  It uses SMTP folded whitespace
  # if it is long.  The folded whitespace is always a single \t.
  chomp($raw_x_dcc = shift @$resp);
  my $v;
  while (($v = shift @$resp) && $v =~ s/^\t(.+)\s*\n/ $1/) {
    $raw_x_dcc .= $v;
  }

  # skip the "reported:" line between the X-DCC header and any checksums
  # remove ':' to avoid a bug in versions 1.3.115 - 1.3.122 in dccsight
  # with the length of "Message-ID:"
  $cksums = '';
  while (($v = shift @$resp) && $v =~ s/^([^:]*):/$1/) {
    $cksums .= $v;
  }

  return ($raw_x_dcc, $cksums);
}

sub ask_dcc {
  my ($self, $tag, $permsgstatus, $fulltext, $envelope) = @_;
  my $conf = $self->{main}->{conf};
  my ($pgm, $err, $sock, $pid, @resp);
  my ($client, $clientname, $helo, $opts);
  my $right;
  my $timeout = $conf->{dcc_timeout};
  my $opts = $conf->{dccifd_options};
  my @opts = !defined $opts ? () : split(' ',$opts);

  $permsgstatus->enter_helper_run_mode();

  my $timeout = $conf->{dcc_timeout};
  my $timer = Mail::SpamAssassin::Timeout->new(
	  { secs => $timeout, deadline => $permsgstatus->{master_deadline} });
  my $err = $timer->run_and_catch(sub {

  $err = $timer->run_and_catch(sub {
    local $SIG{PIPE} = sub { die "__brokenpipe__ignore__\n" };

    # prefer dccifd to dccproc
    if ($self->{dccifd_available}) {
      $pgm = 'dccifd';

      $sock = $self->dccifd_connect($tag);
      if (!$sock) {
	$self->{dccifd_available} = 0;
	die("dccproc not available") if (!$self->is_dccproc_available());
    $sock->print($helo . "\n")   or die "dcc: failed write";  # HELO value
    $sock->print("\n")           or die "dcc: failed write";  # sender
    $sock->print("unknown\r\n")  or die "dcc: failed write";  # recipients
    $sock->print("\n")           or die "dcc: failed write";  # recipients

	# fall back on dccproc if the socket is an orphan from
	# a killed dccifd daemon or some other obvious (no timeout) problem
	dbg("$tag fall back on dccproc");
      }
    }

    if ($self->{dccifd_available}) {

      # send the options and other parameters to the daemon
      $client = $envelope->{ip};
      $clientname = $envelope->{rdns};
      if (!defined $client) {
	$client = '';
      } else {
	$client .= ("\r" . $clientname) if defined $clientname;
      }
      $helo = $envelope->{helo} || '';
      if ($tag ne "dcc:") {
	$opts = $self->{dccifd_report_options}
      } else {
	$opts = $self->{dccifd_lookup_options};
	# only query if there is an X-DCC header
	$opts =~ s/grey-off/& query/ if defined $permsgstatus->{dcc_raw_x_dcc};
      }
      $sock->print($opts)	   or die "failed write options\n";
      $sock->print($client . "\n") or die "failed write SMTP client\n";
      $sock->print($helo . "\n")   or die "failed write HELO value\n";
      $sock->print("\n")	   or die "failed write sender\n";
      $sock->print("unknown\n\n")  or die "failed write 1 recipient\n";
      $sock->print($$fulltext)     or die "failed write mail message\n";
      $sock->shutdown(1) or die "failed socket shutdown: $!";

      $sock->getline()   or die "failed read status\n";
      $sock->getline()   or die "failed read multistatus\n";

      @resp = $sock->getlines();
      die "failed to read dccifd response\n" if !@resp;

    } else {
      $pgm = 'dccproc';
      # use a temp file -- open2() is unreliable, buffering-wise, under spamd
      # first ensure that we do not hit a stray file from some other filter.
      $permsgstatus->delete_fulltext_tmpfile();
      my $tmpf = $permsgstatus->create_fulltext_tmpfile($fulltext);

      my $path = $conf->{dcc_path};
      $opts = $conf->{dcc_options};
      my @opts = !defined $opts ? () : split(' ',$opts);
      untaint_var(\@opts);
      unshift(@opts, '-w', 'whiteclnt');
      $client = $envelope->{ip};
      if ($client) {
	unshift(@opts, '-a', untaint_var($client));
      } else {
	# get external relay IP address from Received: header if not available
	unshift(@opts, '-R');
      }
      if ($tag eq "dcc:") {
	# query instead of report if there is an X-DCC header from upstream
	unshift(@opts, '-Q', 'many') if defined $permsgstatus->{dcc_raw_x_dcc};
      } else {
	# learn or report spam
	unshift(@opts, '-t', 'many');
      }

      dbg("$tag opening pipe to %s",
	  join(' ', $path, "-C", "-x", "0", @opts, "<$tmpf"));

      $pid = Mail::SpamAssassin::Util::helper_app_pipe_open(*DCC,
		$tmpf, 1, $path, "-C", "-x", "0", @opts);
      $pid or die "$!\n";

      # read+split avoids a Perl I/O bug (Bug 5985)
      my($inbuf,$nread,$resp); $resp = '';
      while ( $nread=read(DCC,$inbuf,8192) ) { $resp .= $inbuf }
      defined $nread  or die "error reading from pipe: $!";
      @resp = split(/^/m, $resp, -1);  undef $resp;

      my $errno = 0;  close DCC or $errno = $!;
      proc_status_ok($?,$errno)
	  or info("$tag [%s] finished: %s", $pid, exit_status_str($?,$errno));

      die "failed to read X-DCC header from dccproc\n" if !@resp;
    }
  });

  if ($pgm eq 'dccproc') {
    if (defined(fileno(*DCC))) {	# still open
      if ($pid) {
	if (kill('TERM',$pid)) {
	  dbg("$tag killed stale dccproc process [$pid]")
	} else {
	  dbg("$tag killing dccproc process [$pid] failed: $!")
	}
      }
      my $errno = 0;  close(DCC) or $errno = $!;
      proc_status_ok($?,$errno) or info("$tag [%s] dccproc terminated: %s",
					$pid, exit_status_str($?,$errno));
    }
  }

    dbg("dcc: dccifd got response: %s", $response);
  
  });

  $permsgstatus->leave_helper_run_mode();

  if ($timer->timed_out()) {
    dbg("$tag $pgm timed out after $timeout seconds");
    return (undef, undef);
  }

  if ($err) {
    chomp $err;
    info("$tag $pgm failed: $err\n");
    return (undef, undef);
  }

  my ($raw_x_dcc, $cksums) = $self->parse_dcc_response(\@resp);
  if (!defined $raw_x_dcc || $raw_x_dcc !~ /^X-DCC/) {
    info("$tag instead of X-DCC header, $pgm returned '%s'", $raw_x_dcc);
    return (undef, undef);
  }
  dbg("$tag %s responded with '%s'", $pgm, $raw_x_dcc);
  return ($raw_x_dcc, $cksums);
}

# tell DCC server that the message is spam according to SpamAssassin
sub check_post_learn {
  my ($self, $options) = @_;

  # learn only if allowed
  return if $self->{learn_disabled};
  my $conf = $self->{main}->{conf};
  if (!$conf->{use_dcc}) {
    $self->{learn_disabled} = 1;
    return;
  }
  my $learn_score = $conf->{dcc_learn_score};
  if (!defined $learn_score || $learn_score eq '') {
    dbg("dcc: DCC learning not enabled by dcc_learn_score");
    $self->{learn_disabled} = 1;
    return;
  }

  # and if SpamAssassin concluded that the message is spam
  # worse than our threshold
  my $permsgstatus = $options->{permsgstatus};
  if ($permsgstatus->is_spam()) {
    my $score = $permsgstatus->get_score();
    my $required_score = $permsgstatus->get_required_score();
    if ($score < $required_score + $learn_score) {
      dbg("dcc: score=%d required_score=%d dcc_learn_score=%d",
	  $score, $required_score, $learn_score);
      return;
    }
  }

  # and if we checked the message
  return if (!defined $permsgstatus->{dcc_raw_x_dcc});

  # and if the DCC server thinks it was not spam
  if ($permsgstatus->{dcc_raw_x_dcc} !~ /\b(Body|Fuz1|Fuz2)=\d/) {
    dbg("dcc: already known as spam; no need to learn");
    return;
  }

  # dccsight is faster than dccifd or dccproc if we have checksums,
  #   which we do not have with dccifd before 1.3.123
  my $old_cksums = $permsgstatus->{dcc_cksums};
  return if ($old_cksums && $self->dccsight_learn($permsgstatus, $old_cksums));

  # Fall back on dccifd or dccproc without saved checksums or dccsight.
  # get_dcc_interface() was called when the message was checked

  # is getting the full text this way kosher?  Is get_pristine() public?
  my $fulltext = $permsgstatus->{msg}->get_pristine();
  my $envelope = $permsgstatus->{relays_external}->[0];
  my ($raw_x_dcc, $cksums) = $self->ask_dcc("dcc: learn:", $permsgstatus,
					    \$fulltext, $envelope);
  dbg("dcc: learned as spam") if defined $raw_x_dcc;
}

sub dccsight_learn {
  my ($self, $permsgstatus, $old_cksums) = @_;
  my ($raw_x_dcc, $new_cksums);
  my $response;
  my %count = (body => 0, fuz1 => 0, fuz2 => 0, rep => 0);
  my $timeout = $conf->{dcc_timeout};

  return 0 if !$old_cksums;

  my $dccsight = $self->dcc_pgm_path('dccsight');
  if (!$dccsight) {
    info("dcc: cannot find dccsight") if $dccsight eq '';
    return 0;
  }

  $permsgstatus->enter_helper_run_mode();

  # use a temp file here -- open2() is unreliable, buffering-wise, under spamd
  # ensure that we do not hit a stray file from some other filter.
  $permsgstatus->delete_fulltext_tmpfile();
  my $tmpf = $permsgstatus->create_fulltext_tmpfile(\$old_cksums);
  my $pid;

  my $timeout = $self->{main}->{conf}->{dcc_timeout};
  my $timer = Mail::SpamAssassin::Timeout->new(
	   { secs => $timeout, deadline => $permsgstatus->{master_deadline} });
  my $err = $timer->run_and_catch(sub {

    local $SIG{PIPE} = sub { die "__brokenpipe__ignore__\n" };

    dbg("dcc: opening pipe to %s",
	join(' ', $dccsight, "-t", "many", "<$tmpf"));

    my $opts = $conf->{dcc_options};
    my @opts = !defined $opts ? () : split(' ',$opts);
    untaint_var(\@opts);

    unshift(@opts, "-a",
            untaint_var($client))  if defined $client && $client ne '';

    dbg("dcc: opening pipe: %s",
         join(' ', $path, "-H", "-x", "0", @opts, "< $tmpf"));

    $pid = Mail::SpamAssassin::Util::helper_app_pipe_open(*DCC,
	    $tmpf, 1, $dccsight, "-t", "many");
    $pid or die "$!\n";

    # read+split avoids a Perl I/O bug (Bug 5985)
    my($inbuf,$nread,$resp); $resp = '';
    while ( $nread=read(DCC,$inbuf,8192) ) { $resp .= $inbuf }
    defined $nread  or die "error reading from pipe: $!";
    my @resp = split(/^/m, $resp, -1);  undef $resp;

    my $errno = 0;  close DCC or $errno = $!;
    proc_status_ok($?,$errno)
	  or info("dcc: [%s] finished: %s", $pid, exit_status_str($?,$errno));

    die "dcc: failed to read learning response\n" if !@resp;
      # no facility prefix on this
      die "failed to read header\n";
    }

    ($raw_x_dcc, $new_cksums) = $self->parse_dcc_response(\@resp);
    chomp($response = shift @null);
    # but newer versions of DCC fold the header if it's too long...
    while (my $v = shift @null) {
      last unless ($v =~ s/^\s+/ /);  # if this line wasn't folded, stop
      chomp $v;
      $response .= $v;
    }

    unless (defined($response)) {
      # no facility prefix on this
      die "no response\n";	# yes, this is possible
    }

    dbg("dcc: got response: %s", $response);

  });

  if (defined(fileno(*DCC))) {	  # still open
    if ($pid) {
      if (kill('TERM',$pid)) {
	dbg("dcc: killed stale dccsight process [$pid]")
      } else {
	dbg("dcc: killing stale dccsight process [$pid] failed: $!") }
    }
    my $errno = 0;  close(DCC) or $errno = $!;
    proc_status_ok($?,$errno) or info("dcc: dccsight [%s] terminated: %s",
				      $pid, exit_status_str($?,$errno));
  }
  $permsgstatus->delete_fulltext_tmpfile();
  $permsgstatus->leave_helper_run_mode();

  if ($timer->timed_out()) {
    dbg("dcc: dccsight timed out after $timeout seconds");
    return 0;
  }

  if ($err) {
    chomp $err;
    info("dcc: dccsight failed: $err\n");
    return 0;
    } elsif ($err eq "no response") {
      dbg("dcc: check failed: no response");
    } else {
      warn("dcc: check failed: $err\n");
    }
    return;
  }

  if ($raw_x_dcc) {
    dbg("dcc: learned response: %s", $raw_x_dcc);
    return 1;
    return;
  }

  return 0;
}

# only supports dccproc right now
sub plugin_report {
  my ($self, $options) = @_;


  $self->get_dcc_interface();
  return if $self->{dcc_disabled};

  # get the metadata from the message so we can report the external relay
  $options->{msg}->extract_message_metadata($options->{report}->{main});
  my $envelope = $options->{msg}->{metadata}->{relays_external}->[0];
  my ($raw_x_dcc, $cksums) = $self->ask_dcc("reporter:", $options->{report},
					    $options->{text}, $envelope);

  if (defined $raw_x_dcc) {
    $options->{report}->{report_available} = 1;
    info("reporter: spam reported to DCC");
    $options->{report}->{report_return} = 1;
    } else {
      $client = "0.0.0.0";
    }
    if ($self->dccifd_report($options, $options->{text}, $client, $helo)) {
      $options->{report}->{report_available} = 1;
      info("reporter: spam reported to DCC");
      $options->{report}->{report_return} = 1;
    }
    else {
      info("reporter: could not report spam to DCC via dccifd");
    }
  } else {
    info("reporter: could not report spam to DCC");
    my $tmpf = $options->{report}->create_fulltext_tmpfile($options->{text});
    
    if ($self->dcc_report($options, $tmpf, $client)) {
      $options->{report}->{report_available} = 1;
      info("reporter: spam reported to DCC");
      $options->{report}->{report_return} = 1;
    }
    else {
      info("reporter: could not report spam to DCC via dccproc");
    }
    $options->{report}->delete_fulltext_tmpfile();
  }
}

sub dccifd_report {
  my ($self, $options, $fulltext, $client, $helo) = @_;
  my $conf = $self->{main}->{conf};
  my $timeout = $conf->{dcc_timeout};
  # instead of header use whatever the report option is
  my $opts = $conf->{dccifd_options};
  my @opts = !defined $opts ? () : split(' ',$opts);

  $options->{report}->enter_helper_run_mode();
  my $timer = Mail::SpamAssassin::Timeout->new({ secs => $timeout });

  my $err = $timer->run_and_catch(sub {

    local $SIG{PIPE} = sub { die "__brokenpipe__ignore__\n" };

    my $sock = $self->dccifd_connect();
    $sock or die "report: failed to connect to a dccifd socket";

    # send the options and other parameters to the daemon
    $sock->print("spam " . join(" ",@opts) . "\n")
      or die "report: dccifd failed write"; # options
    $sock->print($client . "\n")
      or die "report: dccifd failed write"; # client
    $sock->print($helo . "\n")
      or die "report: dccifd failed write"; # HELO value
    $sock->print("\n")
      or die "report: dccifd failed write"; # sender
    $sock->print("unknown\r\n")
      or die "report: dccifd failed write"; # recipients
    $sock->print("\n")
      or die "report: dccifd failed write"; # recipients

    $sock->print($$fulltext) or die "report: dccifd failed write";

    $sock->shutdown(1) or die "report: dccifd failed socket shutdown: $!";

    $sock->getline() or die "report: dccifd failed read status";
    $sock->getline() or die "report: dccifd failed read multistatus";

    my @ignored = $sock->getlines();
  });

  $options->{report}->leave_helper_run_mode();
  
  if ($timer->timed_out()) {
    dbg("reporter: DCC report via dccifd timed out after $timeout secs.");
    return 0;
  }
  
  if ($err) {
    chomp $err;
    if ($err eq "__brokenpipe__ignore__") {
      dbg("reporter: DCC report via dccifd failed: broken pipe");
    } else {
      warn("reporter: DCC report via dccifd failed: $err\n");
    }
    return 0;
  }
  
  return 1;
}
  
sub dcc_report {
  my ($self, $options, $tmpf, $client) = @_;
  my $conf = $self->{main}->{conf};
  my $timeout = $options->{report}->{conf}->{dcc_timeout};

  # note: not really tainted, this came from system configuration file
  my $path = untaint_file_path($options->{report}->{conf}->{dcc_path});
  my $opts = $conf->{dcc_options};
  my @opts = !defined $opts ? () : split(' ',$opts);
  untaint_var(\@opts);

  # get the metadata from the message so we can pass the external relay info

  unshift(@opts, "-a",
          untaint_var($client))  if defined $client && $client ne '';

  my $timer = Mail::SpamAssassin::Timeout->new({ secs => $timeout });

  $options->{report}->enter_helper_run_mode();
  my $err = $timer->run_and_catch(sub {

    local $SIG{PIPE} = sub { die "__brokenpipe__ignore__\n" };

    dbg("report: opening pipe: %s",
        join(' ', $path, "-H", "-t", "many", "-x", "0", @opts, "< $tmpf"));

    my $pid = Mail::SpamAssassin::Util::helper_app_pipe_open(*DCC,
                $tmpf, 1, $path, "-H", "-t", "many", "-x", "0", @opts);
    $pid or die "$!\n";

    my($inbuf,$nread,$nread_all); $nread_all = 0;
    # response is ignored, just check its existence
    while ( $nread=read(DCC,$inbuf,8192) ) { $nread_all += $nread }
    defined $nread  or die "error reading from pipe: $!";

    dbg("dcc: empty response")  if $nread_all < 1;

    my $errno = 0;  close DCC or $errno = $!;
    # closing a pipe also waits for the process executing on the pipe to
    # complete, no need to explicitly call waitpid
    # my $child_stat = waitpid($pid,0) > 0 ? $? : undef;
    proc_status_ok($?,$errno)
      or die "dcc: reporter error: ".exit_status_str($?,$errno)."\n";
  });
  $options->{report}->leave_helper_run_mode();

  if ($timer->timed_out()) {
    dbg("reporter: DCC report via dccproc timed out after $timeout seconds");
    return 0;
  }

  if ($err) {
    chomp $err;
    if ($err eq "__brokenpipe__ignore__") {
      dbg("reporter: DCC report via dccproc failed: broken pipe");
    } else {
      warn("reporter: DCC report via dccproc failed: $err\n");
    }
    return 0;
  }

  return 1;
}

1;

=back

=cut

Return to bug 6698