File Coverage

blib/lib/Apache/ProxyScan.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Apache::ProxyScan;

use strict;
use vars qw($VERSION);

use LWP::UserAgent ();
use URI::URL;
use File::MMagic;

use Apache::Const qw(OK DECLINED :log);
use APR::Const qw(:error SUCCESS);
use APR::Table;
use Apache::RequestRec;
use Apache::RequestUtil;
use Apache::RequestIO;
use Apache::Log;
use Apache::Response ();

$VERSION = "0.92";
# create a mime type detector once.
# You need File::Magic even if you don't use it
my $MIME = File::MMagic::new('/etc/magic');

sub handler {
  my($r) = @_;
  return DECLINED unless $r->proxyreq;
  return DECLINED if ($r->method eq "CONNECT");

  # If there are Trusted Extensions DECLINE the requests here
  my $filetype = $r->dir_config("ProxyScanTrustedExtension");
  if (defined $filetype) {
    my %extension;
    foreach (split(/\s+/, $filetype)) {
      s/^\.//igs;
      $extension{lc("$_")} = 1;
    }
    my @pc = (URI::URL->new($r->uri))->path_components;
    my $ext = pop @pc;
    if ($ext =~ s/^.*\.([^.]+)/$1/igs) {
      if (defined $extension{lc("$ext")}) {
	$r->log->warn($r, "Trusted File Extension: ".$r->uri);
	return DECLINED;
      }
    }
  }
  $r->handler("perl-script"); #ok, let's do it
  $r->push_handlers(PerlHandler => \&proxy_handler);
  return OK;
}

sub proxy_handler {
  my($r) = @_;
  # get the configuration variables
  my $scanner = $r->dir_config("ProxyScanScanner");
  my $tmpdir = $r->dir_config("ProxyScanTempDir") || '/tmp/';
  my $presendsize = $r->dir_config("ProxyScanPredeliverSize") || 102400;
  my $trustmime = $r->dir_config("ProxyScanTrustedMIME");
  if (defined $trustmime) {
    $trustmime =~ s/\*/.*/igs;
    $trustmime = join('|', split(/\s+/, $trustmime));
  }

  # create the request
  my $request = new HTTP::Request $r->method, $r->uri;

  # copy request headers
  my $table = $r->headers_in;
  foreach my $key (keys %{$table}) {
      $request->header($key,$table->{$key});
  }

  # transfer request if it's POST
  # try to handle without content length
  if ($r->method eq 'POST') {
    my $len = $r->headers_in->{'Content-length'};
    if (defined $len) {
      my $buf;
      $r->read($buf, $len);
      $request->content($buf);
    } else {
      $request->content(scalar $r->content);
    }
  }

  # do a predeliver
  # if you do predelivering there are several problems with the
  # http protocol. For this reason we do it only for large files.
  # This makes downloading easier, because the save-as window still
  # appears.
  my $callcount = 0;
  my $delivered = 0;
  my $headersent = 0;
  my $trustworthy = 0;
  my $file;
  my $outfile = undef;

  my $fetchref = sub {
    my($data, $res, $protocol) = @_;
    if ($callcount == 0) {
      my $mime = $MIME->checktype_contents($data);
      if ((defined $trustmime ) && ($mime =~ m§^($trustmime)$§i)) {
	$trustworthy = 1;
	$r->log->warn($r, "Trusted MIME Type: ".$r->uri);
	prepareheaders(\$r,\$res);
	$r->rflush();
      } else {
	# make a nice filename
	my @chars = ( "A" .. "Z", "a" .. "z", 0 .. 9 );
	$file = substr($r->uri , 0, 200);
	$file =~ s/[^A-Z0-9]+/_/igs;
	$file .= join("", @chars[ map { rand @chars } ( 1 .. 16 ) ] );
	open($outfile, ">$tmpdir/$file");
	my $len =  $res->header('Content-Length');
	if ($len > $presendsize) {
	  $r->log->warn($r,"started predelivery on: ".$r->uri);
	  $res->remove_header('Content-Length');
	  prepareheaders(\$r,\$res);
	  $r->rflush();
	  $headersent=1;
	  print substr $data,0,5;
	  $delivered += 5;
	  $r->rflush;
	}
      }
    }
    $callcount++;
    if ($trustworthy) {
      print $data;
    } else {
      print $outfile $data;
    }
    return;
  };

  # download request in unique directory

  my $res = (LWP::UserAgent->new(parse_head => 0))->simple_request($request,$fetchref,4096);
  if (defined $outfile) {
    close($outfile);
  }

  # if an error occurs, res->content contains server error
  # we are paraniod so we scan the server message too
  # DNS Errors are reported by LWP::UA as Code 500 with empty content
  if (!$res->is_success) {
    open(my $fh, ">$tmpdir/$file");
    my $msg = $res->content;
    if (($res->code == 500) && ($msg eq "")) {
      $msg = $res->message;
    }
    print $fh $msg;
    close($fh);
  }

  # try to scan file
  if (!$trustworthy) {
    open(my $fh,"$scanner '$tmpdir/$file' |");
    my @msg=<$fh>;
    close($fh);
    my $scanrc = $?;

    # feed reponse back into our request_rec*
    if (!$headersent) {
      prepareheaders(\$r,\$res);
    }

    # The following return code combinations from scanner
    #  rc  file
    #   0  exists    clean, return file
    #   0  deleted   not allowed, fixed error Message
    #  !0  exists    scan failed, fixed error Message
    #  !0  deleted   infected, return stdout

    if ($scanrc == 0) {
      if (-e "$tmpdir/$file") {
        if (!$headersent) {
          $r->rflush();
        }
        $r->sendfile("$tmpdir/$file", $delivered);
      } else {
        if ($res->is_error) {
          if (!$headersent) {
	    $r->rflush();
          }
	  $r->print($res->error_as_HTML);
        } else {
          my $msg=join("\n", @msg);
          generateError(\$r, "Scanner Error", "Scanning ".$r->uri.":\n$msg");
        }
      }
    } else {
      if (-e "$tmpdir/$file") {
        my $msg=join("\n", @msg);
        generateError(\$r, "Scanner Error", "Scanning ".$r->uri.":\n$msg");
      } else {
        $r->headers_out->set("content-length" => undef);
        $r->send_cgi_header(join('', @msg));
	my $entry = join('', @msg);
	$entry =~ s/<.*?>//igs;
	$r->log_error("Virus Alert: ".$r->uri."\n$entry");
      }
    }
    unlink "$tmpdir/$file" if (-e "$tmpdir/$file");
  }
  return OK;
}

sub generateError {
  my $r = shift @_;
  my $title = shift @_;
  my $text = shift @_;

  $$r->log_error("$title: $text");

  $text =~ s/[^A-Z0-9_\s\n]/sprintf("&#%d;", ord($&))/eigs;
  $text =~ s/\n//igs;

  my $msg = "\n\n$title\n\n$title\n$text\n\n";

  $$r->content_type("text/html");
  $$r->headers_out->set("content-length" => length($msg));
  $$r->rflush();
  $$r->print("$msg");

  return 1;
}

sub prepareheaders {
  my $r = shift @_;
  my $res = shift @_;
  $$r->content_type($$res->header('Content-type'));
  $$r->status($$res->code);
  $$r->status_line($$res->status_line);
  my $table = $$r->headers_out;
  $$res->scan(sub {
		$table->add(@_) if ($_[0] !~ m/^Client[_-]/i);
	      });
  return 1;
}


1;

__END__