#!/usr/local/bin/perl -Tw
# -*- Mode: cperl -*-
# small web proxy - Ronan Le Hy
# usage: prox [port]
#   (default port is 8888)
# works fine with Netscape 4.75, ok with Konqueror 1.9.8 (some problem
+s though)

use strict;
use Socket;
use IO::Handle;

sub extract;
sub filter;

$SIG{KILL} = sub {close PROX; close NAV; close HOST; exit;};
# we don't want to exit if a connection is cut
$SIG{PIPE} = sub {};
$SIG{CHLD} = sub {wait;};

my $port_proxy  = $ARGV[0] || 8888;

# if you surf perlmonks with those defaults on, that's gonna be fun :)
my %translation_table = (
              'azatoth' => 'OeufMayo',
              'merlyn' => 'Erudil',
              'BooK' => 'azatoth',
              'mirod' => 'merlyn',
              'Dominus' => 'BooK',
              'tilly' => 'vroom',
              'tye' => 'Dominus',
              'virtualsue' => 'tye',
              'crazyinsomniac' => 'tilly',
              'OeufMayo' => 'virtualsue',
              'Erudil' => 'mirod',
              'vroom' => 'crazyinsomniac',
              'NodeReaper' => 'root',
              'root' => 'NodeReaper' );

# untaint that harmless $port_proxy
if ($port_proxy =~ /(\d*)/)
{
    $port_proxy = $1;
}
else
{
    die "I'd really like to see that happen!\n";
}

# open server a server socket so we can wait for connections
my $tcp = getprotobyname('tcp');
socket(PROX, PF_INET, SOCK_STREAM, $tcp)          || die "socket: $!";
bind(PROX, sockaddr_in($port_proxy, INADDR_ANY))  || die "bind: $!";
listen(PROX,SOMAXCONN)                            || die "listen: $!";

while (accept(NAV, PROX))
{
    # we fork to manage that connection
    unless (fork())
    {
    # the first line of the request (the one with GET)
    my $get = '';
    $get = <NAV> while $get =~ /^\s*$/;

    # we split that first line into interesting elements
    my ($method, $protocol, $host, undef, $port_host, $path, $rest) = 
+extract($get);

    # reading the rest of the request (the header)
    my $bazar = '';
    my $line_header = '';
    $bazar .= $line_header while (($line_header = <NAV>) !~ /^\s+$/);

    # connecting to the web site
    my $host_net = inet_aton($host);
    my $sin = sockaddr_in($port_host, $host_net);
    socket(HOST, PF_INET, SOCK_STREAM, $tcp) or die "cannot open that 
+damn socket\n";
    connect(HOST, $sin) or die "no way to connect to that stupid host\
+n";

    # let's pipe hot! that can do only good
    HOST->autoflush(1);
    PROX->autoflush(1);
    NAV->autoflush(1);

    # making request to web site
    print HOST "$method $path $rest";
    print HOST $bazar, "\015\012"; # that's CR LF

    # read lines from the web site, and transfer them to the browser, 
+via a little filter
    my $ligne = '';
    while (NAV->opened && HOST->opened && ($ligne = <HOST>))
    {
        # the filter
        $ligne = filter($ligne);

        # the string is transmitted back to the browser
        print NAV $ligne;
    }

    # close the sockets and exit the thread
    close HOST;
    close NAV;
    exit;
    }
}


sub extract
{
    # ok, this one was fun to write
    # the regexp splits the given string into ($method, $proto, $host,
+ undef, $port, $path, $rest)
    &{sub {$_[4] ||= 80; return @_;}}($_[0] =~ m#^(\w+)\s+(\w+)://([^/
+:]+)(:?(\d*))(/\S*)(.*)$#);
}

# with the default translation table,
# 'azatoth OeufMayo virtualsue' should give:
# 'OeufMayo virtualsue tye'
sub filter
{
    my $line = shift;
    my $return = $line;

    # for each entry in the table
    foreach my $source (keys %translation_table)
    {
        # in $return, we replace the occurrences of $source with $tran
+slation_table{$source}
        my $len = length $source;
        while ($line =~ /$source/gi)
        {
            substr($return, pos($line) - $len, $len) = $translation_ta
+ble{$source};
        }
    }

    return $return;
}
[download]