view release on metacpan or  search on metacpan

ProxyScan.pm  view on Meta::CPAN

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/httpd/conf/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;
	}
      }