File Coverage

blib/lib/Net/ProxyMod.pm

Criterion	Covered	Total	%
statement	18	149	12.0
branch	0	46	0.0
condition	0	6	0.0
subroutine	6	14	42.8
pod	2	2	100.0
total	26	217	11.9

#
# Copyright (c) 2001,2003,2004 Stephanie Wehner <[e-mail]>
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of the company ITSX nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
# Small tcp proxy package for packet(payload) alteration/debugging.
#
# $Id: ProxyMod.pm,v 1.3 2003/09/23 15:07:32 _ Exp $
#

package Net::ProxyMod;

use strict;
use vars qw($VERSION);
use POSIX ":sys_wait_h";
use Carp;

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

$VERSION = '0.04';

my $do_debug = 0;

my @parnames = qw/
-local_host
-local_port
-remote_host
-remote_port
-debug
/;


# create a new proxy object
sub new
{
    my($caller) = shift;
    my($class)  = ref($caller) || $caller;

    my $self = {};

    bless($self, $class);

    # set defaults, for form
    $self->{-mode} = "forking";

    # initialize the proxy object
    $self->_init(@_);

    return($self);
}


# initialize
sub _init
{
    my $self = shift;

    # care for unnamed and named params
    my $i = 0;
    while (($_[0] !~ /^-/) && ($i < 5)) {
       $self->{$parnames[$i]} = shift;
       $i++;
    }
    my %named = @_;
    $self->{$_} = $named{$_} for keys(%named);

    # check if we need root
    if($self->{-local_port} < 1024 ) {
        croak "Need to be root to create a socket with port < 1024.";
    }

    $do_debug = $self->{-debug};

    # setup the proxy socket
    $self->{MAIN} = IO::Socket::INET->new(
        LocalAddr => $self->{-local_host},
        LocalPort => $self->{-local_port},
        Listen    => Socket::SOMAXCONN,
        ReuseAddr => 1,
        Proto => 'tcp',
    ) or croak "Can't open socket: $!\n";

    _debug(
       "Started server at ",
       $self->{-local_host},
       ":",
       $self->{-local_port},
    );

    # set autoflush
    $self->{MAIN}->autoflush(1);

    if ( $self->{-mode} eq 'nonforking' ) {

        require Tie::RefHash;

        # setup a lookup hash
        tie my %lookup, 'Tie::RefHash'
            or croak "couldn't tie lookup hash";
        $self->{LOOKUP} = \%lookup;

        # setup IO::Select object
        $self->{ALLSOCKS} = IO::Select->new;
        $self->{ALLSOCKS}->add($self->{MAIN});
    }

    return;
}


# handle client connections (this is similar to fwdport
# in the perl coobook in some ways)
sub get_conn
{
    my $self = shift;
    my($infunc, $outfunc) = @_;

    my $func = $self->{-mode} eq 'nonforking' ?
        \&_nonforking
        :
        \&_forking;

    $func->($self, $infunc, $outfunc);
}


# handle forked connections
sub _forking
{
    my $self = shift;
    my($infunc, $outfunc) = @_;

    my($client, $remote, $pid, $buf);

    _debug("Forking server started");

    # reap children
    $SIG{CHLD} = \&_REAPER;

    # get connection
    while($client = $self->{MAIN}->accept()) {

        _debug(
            "Connect from ",
            $client->peerhost(),
            ':',
            $client->peerport(),
        );

        # connect to remote host
        $remote = $self->_make_conn($client);
        next unless $remote;
        $remote->autoflush(1);
        _debug(
            "Remote connection to ",
            $remote->peerhost(),
            ":",
            $remote->peerport()
        );

        $pid = fork();
        unless ( defined($pid) ) {
            carp "Cannot fork: $!\n";
            close($client);
            close($remote);
            next;
        }

        if($pid) {                       # mum
            close($client);
            close($remote);
            next;
        }

        # child
        close($self->{MAIN});

        # create a twin handling the other side
        $pid = fork();
        unless ( defined($pid) ) {
            croak "Cannot fork: $!\n";
        }

        if ( $pid ) {                        # mum # 2

            select($client);
            $| = 1;

            # shovel data from remote to client
            while($remote->sysread($buf, 1024, length($buf))) {
                print $infunc->($buf);
            }

            select(STDOUT);
            _debug(
                "Session closed from remote side ",
                $remote->peerhost(),
                ":",
                $remote->peerport()
            );

            # done, kill child
            kill('TERM', $pid);

        } else {

            select($remote);
            # turn off buffering
            $| = 1;

            # shovel data from client to remote
            while($client->sysread($buf, 1024, length($buf))) {
                print $outfunc->($buf);
            }

            select(STDOUT);
            _debug(
                "Session closed from client side ",
                $client->peerhost(),
                ":",
                $client->peerport()
            );

            # kill parent, since done
            kill('TERM', getppid());
         }
         $remote->close();
         $client->close();

    } # while

    return;
}


sub _nonforking
{
    my $self = shift;
    my($infunc, $outfunc) = @_;

    _debug("Nonforking server started");

    while (1) {

        my @readable = $self->{ALLSOCKS}->can_read(0.05);

        foreach my $sock ( @readable ) {

            if ( $sock == $self->{MAIN} ) {

                # accepting local connection
                my $client = $sock->accept();
                $client->autoflush(1);
                _debug(
                   "Connect from ",
                   $client->peerhost(),
                   ":",
                   $client->peerport()
                );

                # opening remote connection
                my $remote = $self->_make_conn($client);
                next unless $remote;
                $remote->autoflush(1);
                _debug(
                   "Remote connection to ",
                   $remote->peerhost(),
                   ":",
                   $remote->peerport()
                );

                # adding both sockets to IO::Select object
                $self->{ALLSOCKS}->add($client);
                $self->{ALLSOCKS}->add($remote);

                # adding both sockets to socket hash
                # pointing to each other
                $self->{LOOKUP}{$client}  = {
                     sock => $remote,
                     type => 'remote',
                };
                $self->{LOOKUP}{$remote} = {
                     sock  => $client,
                     type  => 'client',
                }

            } elsif ( defined($self->{LOOKUP}{$sock}) ) {

                my $dest   = $self->{LOOKUP}{$sock}{sock};
                my $type   = $self->{LOOKUP}{$sock}{type};
                my $rtype  = $type eq 'client' ? 'remote' : 'client';
                my $func   = $type eq 'client' ? $infunc : $outfunc;

                my $buf;
                my $sel = IO::Select->new($sock);
                while ( $sel->can_read(0.05) ) {
                   last unless $sock->sysread($buf, 1024, length($buf));
                }

                my $err = 0;
                if ( !$buf ) {
                    _debug(
                        "Session closed from $rtype side ",
                        $sock->peerhost(),
                        ":",
                        $sock->peerport()
                    );
                    $err = 1;
                } elsif ( ! print $dest $func->($buf) ) {
                    _debug(
                        "Session closed from $type side ",
                        $sock->peerhost(),
                        ":",
                        $sock->peerport()
                    );
                    $err = 1;
                }

                # remove sockets on error
                if ( $err )  {
                    $self->{ALLSOCKS}->remove($sock, $dest);
                    delete($self->{LOOKUP}{$sock});
                    delete($self->{LOOKUP}{$dest});
                    $sock->close();
                    $dest->close();
                }

            } else {

                # socked already closed?
                next unless $sock->connected();

                # should never happen :-)
                carp "unknown connection ", $sock->peerhost(),
                    ":", $sock->peerport();
            }
        }
    }
}


# reap kids
sub _REAPER
{

    my($child);

    while (($child = waitpid(-1,WNOHANG)) > 0) {
    }

    $SIG{CHLD} = \&_REAPER;
}


#
# Make a connection to the requested destination
#

sub _make_conn
{
    my $self = shift;
    my($sock) = @_;

    # see if this should be transparent proxying or not

    my($dhost, $dport);
    if($self->{-remote_host}) {
        $dhost = $self->{-remote_host};
        $dport = $self->{-remote_port};
    } else {
        # find the actual destination
        $dport = $sock->sockport();
        $dhost = $sock->sockhost();
    }

    _debug("Connecting to ", $dhost, ":", $dport);

    my $newsock = IO::Socket::INET->new(
        PeerAddr => $dhost,
        PeerPort => $dport,
        Proto    => 'tcp',
    ) or carp "Can't connect to $dhost:$dport: $!\n";

    return($newsock);
}


#
# print debug info if desired
#

sub _debug
{
    my(@strings) = @_;

    if ($do_debug) {
        print @strings, "\n";
    }
}


1;
__END__