#
#   MailScanner - SMTP E-Mail Virus Scanner
#   Copyright (C) 2002  Julian Field
#
#   $Id: SweepOther.pm 3638 2006-06-17 20:28:07Z sysjkf $
#
#   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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#   The author, Julian Field, can be contacted by email at
#      Jules@JulianField.net
#   or by paper mail at
#      Julian Field
#      Dept of Electronics & Computer Science
#      University of Southampton
#      Southampton
#      SO17 1BJ
#      United Kingdom
#

package MailScanner::SweepOther;

use strict 'vars';
use strict 'refs';
no  strict 'subs'; # Allow bare words for parameter %'s

use MIME::Head;
use DirHandle;
use HTML::TokeParser;
use POSIX qw(:signal_h setsid); # For Solaris 9 SIG bug workaround

use vars qw($VERSION);

### The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = substr q$Revision: 3638 $, 10;

# Attributes are
#

# Constructor.
sub new {
  my $type = shift;
  my $this = {};

  bless $this, $type;
  return $this;
}

# Do all the non-commercial virus checking and rules systems in here
sub ScanBatch {
  my $batch = shift;
  my $ScanType = shift;

  # Insert your own checking here.
  $0 = 'MailScanner: scanning for filenames and filetypes';

  # In $BaseDir, you will find a directory for each message, which has the
  # same name as the message id. Also there is a messageid.header file
  # containing all the headers for the message.
  # Add entries into %$infections, where they are referenced as
  # $infections->{"message id"}{"filename"} but please don't over-write ones
  # that are already there.
  # If the danger was detected in a header or applies to the whole message
  # then append the error report (and a newline) to
  # $infections->{"message id"}{""}.
  # Return the number of infections/problems you found.
  # Can play with the MIME headers of a message using $mime.

  my($NumInfections, $BaseDir);

  $NumInfections = 0;
  $BaseDir = $global::MS->{work}->{dir};

  chdir $BaseDir or die "Cannot chdir to $BaseDir for rules checking, $!";

  my($id, $attach, $safename, $DirEntry, $message);
  my($basefh, $messagefh, $headerfh);
  my $counter = 0;

  $headerfh = new FileHandle;
  $basefh = new DirHandle;
  $basefh->open('.')
    or MailScanner::Log::DieLog("Could not opendir $BaseDir, %s", $!);
  #print STDERR "In SweepOther::ScanBatch, about to read directory $BaseDir\n";
  while ($DirEntry = $basefh->read()) {
    #print STDERR "In SweepOther::ScanBatch, studying $DirEntry\n";
    next if $DirEntry =~ /^\./;
    stat $DirEntry; # Do a stat now to save multiple calls later

    # Test for presence of dangerous headers
    if (-f _ && $DirEntry =~ /\.header$/) {
      open($headerfh, $DirEntry) or next;
      $id = $DirEntry;
      $id =~ s/\.header$//;
      $message = $batch->{messages}{$id};

      next unless defined $message; # Should be a message for all .header files
      next if $message->{deleted};  # Don't do deleted messages!

      # Check the message if *any* recipient wants dangerous content scanning
      next unless MailScanner::Config::Value('dangerscan', $message) =~ /1/;
      my @headers = <$headerfh>;

      #print STDERR "Checking for Happy virus in $DirEntry ($id)\n";

      # X-Spanska: header ==> "Happy" virus
      if (grep /^X-Spanska:/i, @headers) {
        MailScanner::Log::NoticeLog("Other Checks: Found Happy virus in %s", $id);
        $message->{otherreports}{""} .= "\"Happy\" virus\n";
        $message->{othertypes}{""}   .= "v";
        $counter++;
        $message->{otherinfected}++;
      }

      #print STDERR "Checking for long MIME boundary\n";
      #print STDERR "Entity = " . $message->{entity} . "\n";
      #print STDERR "Boundary = \"" . $message->{entity}->head->multipart_boundary . "\"\n";

      # MIME content boundary longer than 138 ==> Eudora exploit
      if ($message->{entity} &&
          length($message->{entity}->head->multipart_boundary)>=138) {
        MailScanner::Log::NoticeLog("Other Checks: Found Eudora " .
                                  "long-MIME-boundary exploit in %s", $id);
        $message->{otherreports}{""} .= 
          MailScanner::Config::LanguageValue($message,'eudoralongmime') . "\n";
        $message->{othertypes}{""}   .= "v";
        $counter++;
        # And actually try to replace the MIME boundary with a short one
        $message->{entity}->head->mime_attr("Content-type.boundary" =>
                   "__MailScanner_found_Eudora_long_boundary_attack__");
        $message->{otherinfected}++;
      }

      # No other tests on headers
      $headerfh->close();
      next;
    }

    # Test for dangerous attachment filenames specified by filename.rules.conf
    # files.
    if (-d _) {
      $id = $DirEntry;
      $messagefh = new DirHandle;
      $messagefh->open($id) or next;
      $message = $batch->{messages}{$id};

      next unless defined $message; # Should be a message for all .header files
      next if $message->{deleted};  # Don't do deleted messages!

      # Check the message if *any* recipient wants dangerous content scanning
      next unless MailScanner::Config::Value('dangerscan', $message) =~ /1/;

      # Find the name of the TNEF winmail.dat if it exists
      my $tnefname = $message->{entity2file}{$message->{tnefentity}};
      #print STDERR "TNEF Filename is $tnefname\n";

      my $LogNames = MailScanner::Config::Value('logpermittedfilenames',
                                                $message);

      # Set up patterns for simple filename real rules files
      my($allowpatterns, $denypatterns, $allowexists, $denyexists,
         @allowpatterns, @denypatterns, $megaallow,   $megadeny);
      $allowpatterns = MailScanner::Config::Value('allowfilenames', $message);
      $denypatterns  = MailScanner::Config::Value('denyfilenames', $message);
      $allowpatterns =~ s/^\s+//; # Trim leading space
      $denypatterns  =~ s/^\s+//;
      $allowpatterns =~ s/\s+$//; # Trim trailing space
      $denypatterns  =~ s/\s+$//;
      @allowpatterns = split(" ", $allowpatterns);
      @denypatterns  = split(" ", $denypatterns);
      $allowexists   = @allowpatterns; # Don't use them if they are empty!
      $denyexists    = @denypatterns;
      $megaallow     = '(' . join(')|(',@allowpatterns) . ')';
      $megadeny      = '(' . join(')|(',@denypatterns) . ')';
      #print STDERR "allowpatterns = $allowpatterns\n";
      #print STDERR "deny          = $denypatterns\n";
      #print STDERR "megaallow     = $megaallow\n";
      #print STDERR "deny          = $megadeny\n";

      # Insert new filename rules checking code here
      #print STDERR "Searching for dodgy filenames in $id\n";
      #print STDERR "SafeFile2File = " . %{$message->{safefile2file}} . "\n";
      #while (($attach, $safename) = each %{$message->{file2safefile}}) {
      while (defined($safename = $messagefh->read())) {
        #print STDERR "Examinin $id/$safename\n";
        next unless -f "$id/$safename"; # Skip . and ..
        #print STDERR "Real filename of $safename is \"" . $message->{safefile2file}{$safename} . "\"\n";
        $attach = $message->{safefile2file}{$safename} || $tnefname;
        #print STDERR "Safe filename is $safename\n";
        next if $attach eq "" && $safename eq "";
        #print STDERR "Searching long name \"$attach\" short name \"$safename\"\n";
        # New for V4. The ?= on the end makes the regexp match
        # even when the filename is in a foreign character set.
        # This replaces '$' at the end of the string with "(\?=)?$"
        $attach =~ s/\$$/(\\\?=)\?\$/;

        #
        # Implement simple all-matches rulesets for allowing and denying files
        #

        my $MatchFound = 0;
        my($logtext, $usertext);

        # Ignore if there aren't any patterns
        if ($allowexists) {
          #print STDERR "Allow exists\n";
          if ($attach =~ /$megaallow/i || $safename =~ /$megaallow/i) {
            $MatchFound = 1;
            #print STDERR "Allowing filename $id\t$safename\n";
            MailScanner::Log::InfoLog("Filename Checks: Allowing %s %s",
                                      $id, $safename)
              if $LogNames;
          }
        }
        # Ignore if there aren't any patterns
        if ($denyexists) {
          #print STDERR "Deny exists\n";
          if (!$MatchFound && ($attach =~ /$megadeny/i ||
                               $safename =~ /$megadeny/i)) {
            $MatchFound = 1;
            # It's a rejection rule, so log the error.
            $logtext = MailScanner::Config::LanguageValue($message,
                                                        'foundblockedfilename');
            $usertext = $logtext;
            #print STDERR "Denying filetype $id\t$safename\n";
            MailScanner::Log::InfoLog("Filename Checks: %s (%s %s)",
                                      $logtext, $id, $attach);
            $message->{namereports}{$safename} .= "$usertext ($safename)\n";
            $message->{nametypes}{$safename}   .= "f";
            $counter++;
            $message->{nameinfected}++;
          }
        }



        # Work through the attachment filename rules,
        # using the first rule that matches.
        my($i);
        my $FilenameRules = MailScanner::Config::FilenameRulesValue($message);
        next unless $FilenameRules;

        #foreach $i (@$FilenameRules) {
        #  print STDERR "FilenameRule: $i\n";
        #}

        my($allowdeny, $regexp);
        for ($i=0; !$MatchFound && $i<scalar(@$FilenameRules); $i++) {
          ($allowdeny, $regexp, $logtext, $usertext)
            = split(/\0/, $FilenameRules->[$i]);

          #print STDERR "Filename match $i: \"$allowdeny\" \"$regexp\" \"$attach\" \"$safename\" $logtext $usertext\n";
          # Skip this rule if the regexp doesn't match
          # Check both filenames, the safe and the nasty. This is for
          # TNEF messages when the nasty filename is always winmail.dat
          next unless $attach =~ /$regexp/i || $safename =~ /$regexp/i;
          $MatchFound = 1;

          #print STDERR "\"$attach\" matched \"$regexp\" or \"$safename\" did\n";
          if ($allowdeny =~ 'deny') {
            # It's a rejection rule, so log the error.
            MailScanner::Log::InfoLog("Filename Checks: %s (%s %s)",
                                      $logtext, $id, $attach);
            $message->{namereports}{$safename} .= "$usertext ($safename)\n";
            $message->{nametypes}{$safename}   .= "f";
            $counter++;
            $message->{nameinfected}++;
            # Do we want to delete the attachment or store it?
            $message->{deleteattach}{$safename} = 1 if $allowdeny =~ /delete/;
          } else {
            MailScanner::Log::InfoLog("Filename Checks: Allowing %s %s",
                                      $id, $safename)
              if $LogNames;
          }
        }
        MailScanner::Log::InfoLog("Filename Checks: Allowing %s %s " .
                                  "(no rule matched)", $id, $safename)
          if $LogNames && !$MatchFound;
      }
    }
  }
  $basefh->close();

  # Don't do these checks if they haven't specified a filetype rules file
  # or they haven't specified a "file" command
  return $counter if !MailScanner::Config::Value('filecommand');
  return $counter if MailScanner::Config::IsSimpleValue('filetyperules') &&
                     !MailScanner::Config::Value('filetyperules') &&
                     MailScanner::Config::IsSimpleValue('allowfiletypes') &&
                     !MailScanner::Config::Value('allowfiletypes') &&
                     MailScanner::Config::IsSimpleValue('denyfiletypes') &&
                     !MailScanner::Config::Value('denyfiletypes');

  $counter += CheckFileContentTypes($batch);

  return $counter;
}


sub CheckFileContentTypes {
  my($batch) = shift;

  my $BaseDir = $global::MS->{work}->{dir};
  chdir $BaseDir or die "Cannot chdir to $BaseDir for rules checking, $!";

  # Fork and execute the file command against a timeout, capturing output
  # from it.
  # Need "filetimeout" config option

  my($Kid, $pid, $TimedOut, $Counter, $PipeReturn, %FileTypes, $filecommand);
  my(@filelist);
  $Kid  = new FileHandle;
  $TimedOut = 0;
  $filecommand = MailScanner::Config::Value('filecommand');

  eval {
    die "Can't fork: $!" unless defined($pid = open($Kid, '-|'));
    if ($pid) {
      # In the parent
      local $SIG{ALRM} = sub { $TimedOut = 1; die "Command Timed Out" };
      alarm MailScanner::Config::Value('filetimeout');
      # Only process the output if we are scanning, not disinfecting
      while(<$Kid>) {
        chomp;
        $FileTypes{$1}{$2} = $3 if /^([^\/]+)\/([^:]+):\s*(.*)$/;
        #print STDERR "Processing line \"$_\"\n";
      }
      close $Kid;
      $PipeReturn = $?;
      $pid = 0; # 2.54
      alarm 0;
      # Workaround for bug in perl shipped with Solaris 9,
      # it doesn't unblock the SIGALRM after handling it.
      eval {
        my $unblockset = POSIX::SigSet->new(SIGALRM);
        sigprocmask(SIG_UNBLOCK, $unblockset)
          or die "Could not unblock alarm: $!\n";
      };
    } else {
      # In the child
      POSIX::setsid();
      @filelist = <*/*>;
      exit 0 unless @filelist;
      #exec "$filecommand */*"; # Shouldn't do this like this!
      exec(split(/ +/, $filecommand), @filelist);
      MailScanner::Log::WarnLog("Can't run file command " .
                                "(\"$filecommand\"): $!");
      exit 1;
    }
  };
  alarm 0; # 2.53

  # Note to self: I only close the KID in the parent, not in the child.
  MailScanner::Log::DebugLog("Completed checking by $filecommand");

  # Catch failures other than the alarm
  MailScanner::Log::DieLog("File checker failed with real error: $@")
    if $@ and $@ !~ /Command Timed Out/;

  #print STDERR "pid = $pid and \@ = $@\n";

  # In which case any failures must be the alarm
  if ($@ or $pid>0) {
    # Kill the running child process
    my($i);
    kill -15, $pid;
    # Wait for up to 5 seconds for it to die
    for ($i=0; $i<5; $i++) {
      sleep 1;
      waitpid($pid, &POSIX::WNOHANG);
      ($pid=0),last unless kill(0, $pid);
      kill -15, $pid;
    }
    # And if it didn't respond to 11 nice kills, we kill -9 it
    if ($pid) {
      kill -9, $pid;
      waitpid $pid, 0; # 2.53
    }
  }

  # Return failure if the command timed out, otherwise return success
  MailScanner::Log::WarnLog("File checker $filecommand timed out!")
    if $TimedOut;

  # Now check all the %FileTypes we have read in
  $Counter = CheckFileTypesRules($batch, \%FileTypes);
  return $Counter;
}


sub CheckFileTypesRules {
  my($batch, $FileOutput) = @_;

  my($id, $attachtypes, $message, $tnefname, $safename, $type, $attach);
  my $counter = 0;

  while(($id, $attachtypes) = each %$FileOutput) {
    next unless $id;
    $message = $batch->{messages}{$id};

    # Check the message if *any* recipient wants dangerous content scanning
    next unless MailScanner::Config::Value('dangerscan', $message) =~ /1/;

    $tnefname = $message->{entity2file}{$message->{tnefentity}};

    my $LogTypes = MailScanner::Config::Value('logpermittedfiletypes',
                                              $message);

    # Set up patterns for simple filename real rules files
    my($allowpatterns, $denypatterns, $allowexists, $denyexists,
       @allowpatterns, @denypatterns, $megaallow,   $megadeny);
    $allowpatterns = MailScanner::Config::Value('allowfiletypes', $message);
    $denypatterns  = MailScanner::Config::Value('denyfiletypes', $message);
    $allowpatterns =~ s/^\s+//; # Trim leading space
    $denypatterns  =~ s/^\s+//;
    $allowpatterns =~ s/\s+$//; # Trim trailing space
    $denypatterns  =~ s/\s+$//;
    @allowpatterns = split(" ", $allowpatterns);
    @denypatterns  = split(" ", $denypatterns);
    $allowexists   = @allowpatterns; # Don't use them if they are empty!
    $denyexists    = @denypatterns;
    $megaallow     = '(' . join(')|(',@allowpatterns) . ')';
    $megadeny      = '(' . join(')|(',@denypatterns) . ')';
    #print STDERR "allowpatterns = $allowpatterns\n";
    #print STDERR "deny          = $denypatterns\n";
    #print STDERR "megaallow     = $megaallow\n";
    #print STDERR "deny          = $megadeny\n";


    my($i, $FiletypeRules);
    $FiletypeRules = MailScanner::Config::FiletypeRulesValue($message);

    while(($safename, $type) = each %$attachtypes) {
      $attach = $message->{safefile2file}{$safename} || $tnefname;
      next if $attach eq "" && $safename eq "";

      #
      # Implement simple all-matches rulesets for allowing and denying files
      #

      my $MatchFound = 0;
      my($logtext, $usertext);

      # Ignore if there aren't any patterns
      if ($allowexists) {
        if ($type =~ /$megaallow/i) {
          $MatchFound = 1;
          MailScanner::Log::InfoLog("Filetype Checks: Allowing %s %s",
                                    $id, $safename)
            if $LogTypes;
        }
      }
      # Ignore if there aren't any patterns
      if ($denyexists) {
        if (!$MatchFound && $type =~ /$megadeny/i) {
          $MatchFound = 1;
          # It's a rejection rule, so log the error.
          $logtext = MailScanner::Config::LanguageValue($message,
                                                        'foundblockedfiletype');
          $usertext = $logtext;
          MailScanner::Log::InfoLog("Filename Checks: %s (%s %s)",
                                    $logtext, $id, $attach);
          $message->{namereports}{$safename} .= "$usertext ($safename)\n";
          $message->{nametypes}{$safename}   .= "f";
          $counter++;
          $message->{nameinfected}++;
        }
      }

      # Work through the attachment filetype rules,
      # using the first rule that matches.
      next unless $FiletypeRules;
      my($allowdeny, $regexp);
      for ($i=0; !$MatchFound && $i<@$FiletypeRules; $i++) {
        ($allowdeny, $regexp, $logtext, $usertext)
          = split(/\0/, $FiletypeRules->[$i]);

        next unless $type =~/$regexp/i;
        #print STDERR "Filetype match: $allowdeny $regexp $logtext $usertext\n";

        $MatchFound = 1;
        if ($allowdeny =~ /deny/) {
          # It's a rejection rule, so log the error.
          MailScanner::Log::InfoLog("Filetype Checks: %s (%s %s)",
                                    $logtext, $id, $attach);
          $message->{namereports}{$safename} .= "$usertext ($safename)\n";
          $message->{nametypes}{$safename}   .= "f";
          $counter++;
          $message->{nameinfected}++;
          # Do we want to delete the attachment or store it?
          $message->{deleteattach}{$safename} = 1 if $allowdeny =~ /delete/;
        } else {
          MailScanner::Log::InfoLog("Filetype Checks: Allowing %s %s",
                                    $id, $safename)
            if $LogTypes;
        }
      }
      # Log it as allowed if it didn't match any rule
      MailScanner::Log::InfoLog("Filetype Checks: Allowing %s %s " .
                                "(no match found)", $id, $safename)
            if $LogTypes && !$MatchFound;
    }
  }

  return $counter;
}

1;