#!/usr/bin/perl -w
#
# ucbipd.pl - The Unsolicited Comercial Bulk Intellectual Property
# Daemon (UCBIPD), is a deamon that looks for $spambox folders in user
# mail directories, automatically responds to each SPAM message found,
# thanking the SPAMer for asigning all intellectual property rights
# in the SPAMed material to the recipient, archives the SPAMed material
# in a Public Domain Intellectual Property Archive (PDIPA) and then
# deletes the SPAMed material from the user's $spambox.
#
# In order to function, this program requires the perl Mail-Box modules.
# These modules, and their depends, are available from CPAN, the
# Comprehensive Perl Archive Network, at http://www.cpan.org/ or via
# your favorite CPAN mirror.
#
# For full functionality, this program relies on two external programs:
#
#   o  Procmail for autoresponding
#      http://www.procmail.org/
#
#   o  MHonArc for archival
#      http://www.mhonarc.org/
#
# Copyright (C) 2001 Kyle Amon & Steve Mann
# All rights reserved.
#
# Authors:
#
# Kyle Amon
# BackWatcher, Inc.
# Information Security Solutions
# (813) 979-1633
# (203) 668-UNIX
# support@backwatcher.com
# http://www.backwatcher.com/
#               
# Prof. Steve Mann,
# University of Toronto,
# Department of Electrical Engineering,
# Toronto, Ontario, Canada,
# M5S 3G4,
# (416) 946-3387
# mann@eecg.toronto.edu
# http://www.eecg.toronto.edu/~mann/
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# Change history:
#
# 0.10    08-10-01        Alpha release
# 0.11    08-15-01        Fixed broken pipe problem
# 0.12    08-17-01        Added EUID management so $homedir and/or $archive
#                         can be on an NFS mount (RUID must be root now)
# 0.13    08-18-01        Added removal of spam from $spambox after archival
# 0.14    08-19-01        Add MIME and multipart MIME support via MIME-tools
# 0.15    08-20-01        Made debuging more granular via debug={0,1,2,3,4}
# 0.16    08-20-01        Added email address 'slurping' from spam bodies
# 0.17    08-20-01        Added CCing of Reply-To and slurped addresses
# 0.18    12-17-01        Added add spamming MTA to sendmail's access database
#
# TODO (ordered roughly by difficulty/priority):
#
# o  Fix multi-part mail handling (Mail::Box has issues)
# o  Add slurping of phone numbers from spam bodies.
# o  Add calling of toll free SPAMer numbers with synthesized message.
# o  Add ability to be run by/for a single user.
# o  Remove dependence on procmail for autoresponding.
# o  Add ability to use centralized archive on a remote server.
# o  Add ability to use remote IMAP/POP servers.
# o  Write some documentation. :-)

require 5.004;
use strict;
use POSIX qw(setsid);
use Mail::Box::Manager;
use Mail::Box::Tie;
use MIME::Parser;

#
# user defined variables
#

my $asigne	= 'Kyle Amon, Inc.';		# Intellectual Property asignee
my $bcc		= 'amonk@gnutec.com';		# Bcc: address for debuging
my $pfrom	= 'ucbipd@gnutec.com';		# From: address of ucbipd.pl
my $smtp	= 'mailhub.dmz.gnutec.com';	# your smtp server
my $homedir	= '/home';			# user home directory
my $maildir	= 'mail';			# user mail directory
my $spambox	= '.spam';			# user spam folder
my $tcu		= '.tcu';			# Terms & Conditions of Use file
my $mhonarc	= '/usr/local/bin/mhonarc';	# mhonarc archival utility
my $archive	= '/home/amonk/public_html/pdipa';	# PD IP archive
my $reject	= '1';				# add reject: 0 = no ; 1 = yes
my $rejectmsg	= 'Send $10/mo. to 6002 Palm Shadow Way, Suite 1218 Tampa, FL. 33647 for UCBE services';			# reject message
my $access	= '/etc/mail/access';		# sendmail's access file
my $cp		= '/bin/cp';			# location of cp command
my $makemap	= '/usr/sbin/makemap';		# location of makemap command
my $interval	= '3600';			# sleep interval in seconds
my $debug	= '0';				# debuging: 0 = off
						#           1 = status info
						#           2 = Header info
						#           3 = MIME info
						#           4 = MIME barf

#
# main symbol declerations
#

my (
     @users, $user, $uid, $auser, $spams, $mail, $head, $spam, $line,
     @tcu, @dtcu,
     $to, $from, $subject,
     @files, $replyto,
     $mgr, $folder, @spambox, $msg, $msgid,
     @body, @msg, @lines, @part, $part, @ccs,
     $source, $message, @accesslines, @received
);

main ();
exit;


#
# main subroutine
#

sub main {

  my $pver = '0.18';				# set program version
  my $pname = "$0" if ( $0 =~ s/.*\/// );	# get/set program name
  print "$pname v$pver\n" if ($debug >= 1);

  delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};     # secure %ENV
  $ENV{PATH} = "/bin:/usr/bin";                 # secure PATH

  $| = 1;					# flush the buffer

  &daemonize if (!$debug);			# daemonize the program

  &access_clean if ($reject == 1);		# clean sendmail's access file

  #
  # infinite loop
  # 

  while(1) {

    #
    # find and process all users with $spambox folders
    #

    @users = listdir ("$homedir");
    foreach $user (@users) {

      $uid = (getpwnam($user)) [2];		# get UID of $user
      $> = $uid;				# set EUID to UID of $user

      print "\nUser: $user [$uid:$>]\n" if ($debug >= 1);

      if (-f "$homedir/$user/$maildir/$spambox") {
        print "      has $spambox folder...\n" if ($debug >= 1);

        #
	# get user's $tcu or use $dtcu (default tcu)
	#

        if (-f "$homedir/$user/$tcu") {
          print "      has $tcu file...\n" if ($debug >= 1);
          open (TCU, "$homedir/$user/$tcu") || die "cannot open: $!";
          foreach $line (<TCU>) {
            $line =~ s/ASIGNE/$asigne/g;
            $line =~ s/\.\./\./g;
            push @tcu, $line;
          }
          close TCU;
        } else {
          print "      has no $tcu file...\n" if ($debug >= 1);
          @dtcu = deftcu();
          foreach $line (@dtcu) {
            $line =~ s/ASIGNE/$asigne/g;
            $line =~ s/\.\./\./g;
            push @tcu, $line;
          }
        }

        #
	# process user's $spambox
	#

        $mgr = Mail::Box::Manager->new;
        $folder = $mgr->open(folder => "$homedir/$user/$maildir/$spambox",
                             access => 'rw');

        my $emails = $folder->messages;		# spam count
        for (my $i = 0; $i < $emails; $i++) {
          $msg = $folder->message($i);
          chomp ($subject) if ($subject = $msg->head->get('subject'));
          $subject = 'nada' if (!$subject);	# make sure $subject not empty
          $_ = $subject;
          if (! /FOLDER INTERNAL DATA/) {

            $msgid = $msg->messageID;
            print "\n  Message-ID: $msgid\n" if ($debug >= 1);

            print "     Subject: $subject\n" if ($subject && $debug >= 2);
            chomp ($replyto) if ($replyto = $msg->head->get('reply-to'));
            print "    Reply-To: $replyto\n" if ($replyto && $debug >= 2);
            chomp ($from) if ($from = $msg->head->get('from'));
            $from = 'nada' if (!$from);		# make sure $from not empty
            print "        From: $from\n" if ($from && $debug >= 2);
            chomp ($to) if ($to = $msg->head->get('to'));
            $to = 'nada' if (!$to);		# make sure $to not empty
            print "          To: $to\n" if ($to && $debug >= 2);

            my $parser = MIME::Parser->new;
            $parser->output_dir("/tmp");

            @msg = (@{$msg->header}, "\n", @{$msg->body});
            my $ent = $parser->parse_data(\@msg)
              or die "couldn't parse MIME stream\n";

            my $reply = MIME::Entity->build(Type          => "multipart/mixed",
                                            From          => "\"$to\" <$pfrom>",
                                            To            => "$from",
                                            Subject       => "Re: $subject",
                                            Sender        => "$pname",
                                            Encoding      => '-SUGGEST');

            $reply->attach(Type     => "text/plain",
                           Data     => \@tcu);

            if (! $msg->is_multipart) {

              print "--\n" if ($debug >= 4);
              $ent->dump_skeleton if ($debug >= 4);

              my $bh = $ent->bodyhandle;

              my $io = $bh->open("r") || die "open body: $!";
              while (defined($_ = $io->getline)) {
##                print "$_" if ($debug >= 4);
                push @lines, "$_";
                &slurpaddrs();			# slurp off any email addresses
              }
              $io->close || die "close I/O handle: $!";

              @part = @lines;

              my $etype = $ent->effective_type;
              print "              Content-type: $etype\n" if ($debug >= 3);

              $reply->attach(Type     => "$etype",
                             Data     => \@part);

              undef @lines;		# clear @lines array

              $bh->purge;		# delete temporary files

            } else {

              foreach $part ($folder->message($i)) {

                print "              start part loop...\n";

         #       if (! $part->is_multipart) {

         #         my $ppparser = MIME::Parser->new;
         #         $ppparser->output_dir("/tmp");

         #         my @pmsg = (@{$part->header}, "\n", @{$part->body});
         #         my $ppent = $ppparser->parse_data(\@pmsg)
         #           or die "couldn't parse MIME stream\n";

         #         my $bbh = $ppent->bodyhandle;

         #         my $pio = $bbh->open("r") || die "open body: $!";
         #         while (defined($_ = $pio->getline)) {
##       #           print "$_" if ($debug >= 4);
         #           push @lines, "$_";
         #           &slurpaddrs();		# slurp off any email addresses
         #         }
         #         $pio->close || die "close I/O handle: $!";

         #         @part = @lines;

         #         my $etype = $ppent->effective_type;
         #         print "              Content-type: $etype\n" if ($debug >= 3);

         #         $reply->attach(Type     => "$etype",
         #                        Data     => \@part);

         #         undef @lines;		# clear @lines array

         #         $bbh->purge;		# delete temporary files

         #       } else {

         #         my $pparser = MIME::Parser->new;
         #         $pparser->output_dir("/tmp");

#        #          my $ph = new MIME::Body::InCore \@part;
         #         my $pent = $pparser->parse($part)
         #           or die "couldn't parse MIME stream\n";

         #         foreach my $ppart ($pent->parts) {

                    print "              part loop...\n";
                    print "$part" if ($debug >= 4);
                    print "--\n" if ($debug >= 4);
                    $part->dump_skeleton if ($debug >= 4);

                    my $etype = $part->effective_type;
                    print "            Content-type: $etype\n" if ($debug >= 3);

#                    &slurpaddrs();	# slurp off any email addresses
#                    @part = @lines;

                    $reply->attach(Type     => "$etype",
                                   Data     => \@part);

#                    undef @lines;		# clear @lines array

#                    $part->purge;		# delete temporary files
         #         }

         #       }

              }

#              $ent->purge;		# delete temporary files

            }

            foreach (@ccs) {
              print "              CC slurped: $_\n" if ($debug >= 2);
            }

            if ($replyto) {
              print "              CC Reply-To: $replyto\n" if ($debug >= 2);
              push @ccs, "$replyto";	# add $replyto to CC
            }

            print "              [$uid:$>] replying...\n" if ($debug >= 1);
            $reply->head->add('Cc', join(',', @ccs)) if (@ccs);	# add Cc header
            $reply->head->add('Bcc', "$bcc") if ($debug);	# add Bcc header
            $reply->smtpsend(Host  => "$smtp");		# send wholesale reply

            undef @ccs;		# clear @ccs array

            $> = $<;		# set EUID back to RUID
            &archive();		# archive spam material
            $> = $<;		# set EUID back to RUID
            &access_add if ($reject == 1);	# reject spamming MTA in future

            $uid = (getpwnam($user)) [2];	# get UID of $user
            $> = $uid;				# set EUID to UID of $user

            print "              [$uid:$>] deleting...\n" if ($debug >= 1);
            $msg->delete;			# mark $msg for deletion

          }

        }

        if ($> == $uid) {
          print "      writing $spambox changes\n" if ($debug >= 1);
          $folder->write;		# write folder changes
        } else {
          print "      not writing $spambox changes\n" if ($debug >= 1);
          print "      UID:EUID [$uid:$>] mismatch\n" if ($debug >= 1);
        }

        $mgr->close($folder);		# close folder
        undef @tcu;			# clear @tcu array

      }

      $> = $<;				# set EUID back to RUID

    }

    &access_rebuild if ($reject == 1);	# rebuild sendmail's access database

    sleep($interval);			# sleep $interval seconds
  }

}

sub deftcu {

  push @dtcu, "Thank you for submitting this material to ASIGNE's\n";
  push @dtcu, "Intellectual Property Doner Site.  Intellectual property\n";
  push @dtcu, "rights in this material have now been asigned to ASIGNE.\n";
  push @dtcu, "For your reference, here is a copy of the agreement to which\n";
  push @dtcu, "you have bound yourself.\n";
  push @dtcu, "\n";
  push @dtcu, "  Terms and Conditions of Use:\n";
  push @dtcu, "\n";
  push @dtcu, "  By submitting email to this address, you agree to the\n";
  push @dtcu, "  following Terms and Conditions.  You asign, to ASIGNE,\n";
  push @dtcu, "  any and all intellectual property rights in any material\n";
  push @dtcu, "  sent to this email address.  You agree that you will not\n";
  push @dtcu, "  reproduce, sell, transfer, or modify any data presented\n";
  push @dtcu, "  in response to your submission, or use any such data for\n";
  push @dtcu, "  commercial purpose without the prior, express, written\n";
  push @dtcu, "  permission of ASIGNE.  By having read these Terms and\n";
  push @dtcu, "  Conditions, you agree to whatever terms ASIGNE might wish\n";
  push @dtcu, "  to impose upon you in the future, regardless of whether or\n";
  push @dtcu, "  not they pertain to this message.\n";
  push @dtcu, "\n";
  push @dtcu, "Thank you once again for asigning all intellectual property\n";
  push @dtcu, "rights in this material to ASIGNE.  For your reference, a\n";
  push @dtcu, "copy of the material you asigned all intellectual property\n";
  push @dtcu, "rights to ASIGNE for, by mailing it to ASIGNE's\n";
  push @dtcu, "Intellectual Property Doner Site, is attached.\n";
  push @dtcu, "\n";

  return @dtcu;

}

sub archive {

  if ( -f $mhonarc && -d $archive ) {

    $auser = (stat($archive))[4];		# get UID of $archive
    $> = $auser;				# set EUID to UID of $archive

    print "              [$uid:$>] archiving...\n" if ($debug >= 1);
    open(MHONARC, "| $mhonarc -quiet -add -outdir $archive")
      || die "can't fork: $!";

    foreach $line (@msg) {
      print MHONARC $line;
    }

    local $SIG{PIPE} = sub {print "caught sigpipe: $!\n" if ($debug >= 1)};
    close MHONARC
      || print "bad $mhonarc close: $! status=$?\n" if ($debug >= 1);

  } else {

    print "              not archiving...\n" if ($debug >= 1);
    print "              $mhonarc or $archive missing\n" if ($debug >= 1);

  }

}

sub access_clean {

  if ( -f $access ) {

    #
    # Make backup of $access
    #

    print "\nbacking up $access...\n" if ($debug >= 1);
    system "$cp", "$access", "$access.old"
      || die "cp $access $access.old failed: $!\n";

    #
    # Open $access backup file, lower case first column,
    # strip comment lines and store in array
    #

    open (ACCESSBAK, "< $access.old") || die "cannot open: $!";
    while (<ACCESSBAK>) {
      if (!($_ =~ s/^#.*//)) {
        ($source, $message) = split(/		/);
        $source =~ tr/A-Z/a-z/;
        $_ = "$source		$message";
        push @accesslines, $_;			# add line to array
      }
    }

    close ACCESSBAK;				# be tidy

    #
    # Write sorted, unique lines to $access
    #

    print "cleaning $access...\n" if ($debug >= 1);

    open ACCESS, "> $access" || die "cannot open: $!";
    my $prev='nada';				# initialize $prev
    print ACCESS sort grep($_ ne $prev && ($prev = $_), @accesslines);
    close ACCESS;				# be tidy

  } else {

    print "              not cleaning $access...\n" if ($debug >= 1);
    print "              $access missing\n" if ($debug >= 1);

  }

}

sub access_add {

  if ( -f $access ) {

    #
    # Get SMTP Received: lines and put [real] source MTAs in array
    #

    foreach $_ (@msg) {
      if ( /^Received: from / ) {		# if SMTP Received: line
          chomp;				# strip trailing newline
          print "    $_\n" if ($debug >= 2);
        if ( /.+ from .*\(.*\[.+\].*\)/ ) {	# if contains [real] source MTA
          $_ =~ s/.*\[//;			# strip leading '[' and before
          $_ =~ s/\].*//;			# strip trailing ']' and after
          push @received, $_;			# add source MTA to array
        }
      }
    }

    #
    # Add reject line for source MTA to sendmail's access file
    #

    print "              [$uid:$>] rejecting [$received[0]]...\n" if ($debug >= 1);

    open ACCESS, ">> $access" || die "cannot open: $!";
    print ACCESS "$received[0]		550 $rejectmsg\n";
    close ACCESS;				# be tidy

    #
    # Empty the @received array
    #

    while (pop @received) {
      pop @received;
    }

  } else {

    print "              not adding reject...\n" if ($debug >= 1);
    print "              $access missing\n" if ($debug >= 1);

  }

}

sub access_rebuild {

  if ( -f $access ) {

    #
    # Rebuild the sendmail access database
    #

    print "              [$uid:$>] rebuilding $access...\n" if ($debug >= 1);

    open MAKEMAP, "| $makemap hash $access";
    open ACCESS, "< $access" || die "cannot open: $!";
    while (<ACCESS>) {
      print MAKEMAP $_;
    }
    close ACCESS;				# be tidy
    close MAKEMAP;				# be tidy 

  } else {

    print "              not rebuilding $access...\n" if ($debug >= 1);
    print "              $access missing\n" if ($debug >= 1);

  }

}

sub slurpaddrs {

  if ( /[\w\-]+\@[\w\-]+\.[\w\-]+/ ) {	# if smelling of an email address
    $_ =~ s/.*://;			# strip leading 'mailto:' and before
    $_ =~ s/\?.*//;			# strip trailing '?' and after
    $_ =~ s/.*>//;			# strip any leading html crap
    $_ =~ s/<.*//;			# strip any trailing html crap
    $_ =~ s/.* //;			# strip leading space and before
    $_ =~ s/ .*//;			# strip trailing space and after
    chomp;				# strip trailing newline
    push @ccs, $_;			# add address to CC list
  }

}

sub listdir {

  opendir(DIR, "$_[0]") || die "can't opendir $_[0]: $!";
  @files = grep { /^[^\.]/ && -d "$_[0]" } readdir(DIR);
  closedir DIR;
  return @files;

}

sub daemonize {

  chdir '/' or die "Can't chdir to /: $!";
  open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
  open STDOUT, '>>/dev/null'or die "Can't write to /dev/null: $!" if (!$debug);
  open STDERR, '>>/dev/null' or die "Can't write to /dev/null: $!" if (!$debug);
  defined(my $pid = fork) or die "Can't fork: $!";
  exit if $pid;
  setsid or die "Can't start a new session: $!";
  umask 077;

}