A Proxy in Perl

This is a proxy that I have written to demonstrate the http protocol. If you use it on Windows, make sure you disable the annoying beep

I wanted this proxy to be small and understandable so as to be able to tweak it. So, there is no logging functionality for example or other bells and whistels.

http_proxy.pl

use strict;
use URI;
use IO::Socket;

my $showOpenedSockets=1;

my $server = IO::Socket::INET->new (
   LocalPort => 8080,
   Type      => SOCK_STREAM,
   Reuse     => 1,
   Listen    => 10);


binmode $server;

while (my $browser = $server->accept()) {
  print "\n\n--------------------------------------------\n";

  binmode $browser;

  my $method              ="";
  my $content_length      = 0;
  my $content             = 0;
  my $accu_content_length = 0;
  my $host;
  my $hostAddr;
  my $httpVer;

  while (my $browser_line = <$browser>) {
    unless ($method) {
      ($method, $hostAddr, $httpVer) = $browser_line =~ /^(\w+) +(\S+) +(\S+)/;

      my $uri = URI->new($hostAddr);

      $host = IO::Socket::INET->new (
        PeerAddr=> $uri->host,
        PeerPort=> $uri->port );

        die "couldn't open $hostAddr" unless $host;

      if ($showOpenedSockets) {
        print "Opened ".$uri->host." , port ".$uri->port."\n";
      }

      binmode $host;

      print $host "$method ".$uri->path_query." $httpVer\n";
      print "$method ".$uri->path_query." $httpVer\n";
      next;
    }

    $content_length = $1 if      $browser_line=~/Content-length: +(\d+)/i;
    $accu_content_length+=length $browser_line;

    print $browser_line;

    print $host $browser_line;

    last if $browser_line =~ /^\s*$/ and $method ne 'POST';
    if ($browser_line =~ /^\s*$/ and $method eq "POST") {
      $content = 1;
      last unless $content_length;
      next;
    }
    if ($content) {
      $accu_content_length+=length $browser_line;
      last if $accu_content_length >= $content_length;
    }
  }
  print "\n\n....................................\n";
  
  $content_length      = 0;
  $content             = 0;
  $accu_content_length = 0;
  while (my $host_line = <$host>) {
    print $host_line;
    print $browser $host_line;
    $content_length = $1 if $host_line=~/Content-length: +(\d+)/i;
    if ($host_line =~ m/^\s*$/ and not $content) {
      $content = 1;
      #last unless $content_length;
      next;
    }
    if ($content) {
      if ($content_length) {
        $accu_content_length+=length $host_line;
        #print "\nContent Length: $content_length, accu: $accu_content_length\n";
        last if $accu_content_length >= $content_length;
      }
    }
  }
  $browser-> close;
  $host   -> close;
}

The proxy as a package

The following package can be used for a generic proxy, that is, it just forwards what it receives without interpreting it. It must be noted, that it is not multithreaded, and only forwards one connection.

proxy.pm

package proxy;

use strict;
use warnings;

use IO::Socket;
use IO::Select;
use IO::Handle;

sub new {
  my $obj  = shift;
  my $self = {};

  my $proxy_port           = shift;

  $self->{server_host}     = shift;
  $self->{server_port}     = shift;

  $self->{client_callback} = shift;
  $self->{server_callback} = shift;

  $self->{proxy} = IO::Socket::INET->new (
   LocalPort => $proxy_port,
   Type      => SOCK_STREAM,
   Reuse     => 1,
   Listen    => 10);

  binmode $self->{proxy};

  return bless $self, $obj;
}

sub accept {
  my $self = shift;

  my $client = $self-> {proxy} -> accept();
  binmode $client;

  my $server = IO::Socket::INET->new (
           PeerAddr => $self->{server_host},
           PeerPort => $self->{server_port});

  binmode $server;

  $client->blocking(0);
  $server->blocking(0);

  my $select = new IO::Select;
  $select->add($server);
  $select->add($client);

  autoflush $server;
  autoflush $client;

  while (my @ready = $select->can_read()) {
    foreach my $fd (@ready) {

      my $buf="";

      if ($fd == $client) {
        sysread($client, $buf, 1024);
        &{$self->{client_callback}}($buf);
        print $server $buf;
      }

      if ($fd == $server) {
        sysread($server, $buf, 1024);
        &{$self->{server_callback}}($buf);
        print $client $buf;
      }
    }
  }
}

1;

This package is then used like so:

use proxy;

use strict;
use warnings;

sub from_client {
  print "\n\nFrom client:\n";
  print shift;
}

sub from_server {
  print "\n\nFrom server:\n";
  print shift;
}

my $proxy = new proxy(
   7777, 
  'www.adp-gmbh.ch', 
   80,
 \&from_client,
 \&from_server
  );

$proxy->accept();

Links

This package is used in On a breakable Oracle to demonstrate a critical security bug.

Thanks

Thanks to Paul Harman who notified me of a bug in proxy.pl.


	René Nyffenegger's collection of things on the web
	René Nyffenegger on Oracle - Most wanted - Feedback