#!/usr/bin/perl
use Fcntl;
use Errno;
use IO::Socket::INET;
use Pod::Usage qw/pod2usage/;
use warnings;
use strict;
our $VERSION = 0.01;
my $prog = ($0 =~ m{([^/]+)$})[0];
my $usage = "$prog [OPTIONS] -l|-c host1:port1 -l|-c host2:port2";
my $count = undef;
my $fork = 0;
my $verbose = 0;
my $bufsize = 1024;
my @lsocks;
my @addr;
while (@ARGV) {
my $flag = shift;
if ($flag eq '-l' && @addr < 2) {
push @addr, (shift or die $usage);
push @lsocks, lsock($addr[-1]);
}
elsif ($flag eq '-c' && @addr < 2) {
push @addr, (shift or die $usage);
push @lsocks, undef;
}
elsif ($flag eq '-N' && @ARGV) {
$count = 0+shift;
}
elsif ($flag eq '-k') {
$fork = 1;
}
elsif ($flag eq '-s') {
$bufsize = 0+(shift or die $usage);
}
elsif ($flag eq '-V') {
print $VERSION."\n";
exit 0;
}
elsif ($flag eq '-v') {
$verbose++;
}
elsif ($flag eq '-h') {
pod2usage();
}
else {
die $usage;
}
}
die $usage unless @addr == 2;
for (my $n=0; !defined $count || $n<$count; $n++) {
my @socks;
for my $i (0, 1) {
$socks[$i] = $lsocks[$i] ? asock($lsocks[$i]) : csock($addr[$i]);
$socks[$i] = nonblock($socks[$i]);
verbose(1, sprintf 'sock %s %d', $addr[$i], fileno $socks[$i]);
}
if ($fork) {
defined (my $pid = fork) or
die "fork error: $!";
if ($pid == 0) {
verbose(1, "fork $$");
forward(@socks);
verbose(1, "exit $$");
exit(0);
}
}
else {
forward(@socks);
}
}
while ($fork && wait >= 0) {}
exit 0;
sub forward {
my @socks = @_;
my @eof;
while (my @readable = map $socks[$_] => grep !$eof[$_] => (0, 1)) {
my $rin = fdset(@readable);
select(my $rout=$rin, undef, undef, undef) >= 0 or
die "select error: $!";
if (vec($rout, fileno $socks[0], 1)) {
$eof[0] = !transfer($socks[0], $socks[1]);
$socks[1]->shutdown(1) if $eof[0];
}
if (vec($rout, fileno $socks[1], 1)) {
$eof[1] = !transfer($socks[1], $socks[0]);
$socks[0]->shutdown(1) if $eof[1];
}
}
}
sub transfer {
my ($rfh, $wfh) = @_;
my $total = 0;
my $bytes;
while ($bytes = sysread $rfh, my $data, $bufsize) {
$total += $bytes;
while ($bytes > 0) {
my $written = syswrite $wfh, $data, $bytes, length($data) - $bytes;
die "write error: $!" if !defined $written && !$!{EAGAIN};
$bytes -= $written if defined $written;
}
}
verbose(1, sprintf 'xfer %d %d %d', fileno $rfh, fileno $wfh, $total);
return 0 if defined $bytes; # sysread == 0, EOF
return 1 if $!{EAGAIN};
die "read error: $!";
}
sub lsock {
my $addr = shift;
my $sock = IO::Socket::INET->new(
LocalAddr => $addr, Listen => SOMAXCONN, ReuseAddr => 1, @_) or
die "listen error for $addr: $!";
return $sock;
}
sub asock {
my $listen = shift;
my $sock = $listen->accept or
die "accept error: $!";
return $sock;
}
sub csock {
my $addr = shift;
my $sock = IO::Socket::INET->new(PeerAddr => $addr, @_) or
die "connect error for $addr: $!";
return $sock;
}
sub nonblock {
my $fh = shift;
my $flags = fcntl $fh, F_GETFL, 0 or
die "fcntl error: $!";
fcntl $fh, F_SETFL, $flags | O_NONBLOCK or
die "fcntl error: $!";
return $fh;
}
sub fdset {
my $set = '';
vec($set, fileno $_, 1) = 1 for @_;
return $set;
}
sub verbose {
my $level = shift;
print join("\n" => @_, '') if $verbose >= $level;
}
__END__
=head1 NAME
tcpforward - forward or tunnel TCP connections
=head1 SYNOPSIS
tcpforward [OPTIONS] -l|-c host1:port1 -l|-c host2:port2
-l host:port listen on host:port, forward accepted connections
-c host:port connect to host:port, forward this connection
-N count exit after forwarding count connections
-k fork before forwarding (default: no)
-s size chunk size for non-blocking reads (default: 1024)
-V print version and exit
-v turn on parseable logging
-h display usage information
=head1 EXAMPLES
Forward local SMTP to a remote mailserver:
$ tcpforward -k -c mailserver:25 -l localhost:25
Forward tunnel the SSH service on 10.0.0.100 to 10.0.0.101:
[10.0.0.100]$ tcpforward -l 10.0.0.100:9922 -c localhost:22
[10.0.0.101]$ tcpforward -c 10.0.0.100:9922 -l localhost:22
[10.0.0.101]$ ssh localhost
Reverse tunnel the SSH service on 10.0.0.100 to 10.0.0.101:
[10.0.0.101]$ tcpforward -l 10.0.0.101:9922 -l localhost:22
[10.0.0.100]$ tcpforward -c 10.0.0.101:9922 -c localhost:22
[10.0.0.101]$ ssh localhost
=head1 DESCRIPTION
tcpforward is a userspace TCP connection forwarder. It uses efficient
non-blocking I/O and is protocol agnostic.
Some uses include:
=over
=item *
Making remote services look like local ones
=item *
Offering a service on a different port number without restarting it
=item *
Allowing a non-root user to bind to a selected low port
=item *
Tunneling connections into NAT'ed networks or past firewalls
=item *
Evenly distributing a service-oriented architecture
=item *
Monitoring a service's network usage
=back
=head1 SECURITY
tcpforward does B<not> provide encryption of any sort. Forward
only encrypted connections if security is an issue. Consider SSH tunneling
or stunnel if you need an encrypted tunnel.
That said, part of the original motivation for tcpforward was reverse
tunneling of the SSH service itself back through a NAT'ed gateway.
Using ssh to establish the tunnel would have incurred the penalty of
double encryption.
=head1 OPTIONS
=over 4
=item -c host:port
Connect to host:port, then do forwarding on the socket.
=item -l host:port
Listen for connections on host:port, then do forwarding on the accepted socket.
=item -N count
Exit after forwarding count TCP connections.
=item -k
Fork and perform forwarding in a child process. This permits multiple
simultaneous forwarded connections. The default is non-forking.
=item -s size
When forwarding, attempt non-blocking reads of size bytes at a time. Setting
this to the median packet size for a given protocol may result in some small
performance gain.
=item -v
Print version number and exit.
=item -v
Turn on parseable logging to standard out. Increase logging level with
extra -v options.
=item -h
Display usage information.
=back
=head1 BUGS
tcpforward should be rewritten in C. Please report other bugs on CPAN.
=head1 AUTHOR
Alan Grow <agrow+nospam@thegotonerd.com>
=head1 COPYRIGHT
Copyright (C) 2007 by Alan Grow
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself, either Perl version 5.8.3 or, at
your option, any later version of Perl 5 you may have available.
=cut