#!/usr/bin/perl -T
#
# Copyright 2002, 2003, 2004, 2007 Michael H. Buselli
# License and copying terms are below the usage information.
#
# Usage:  portforw local-if:local-port//remote-host:remote-port
#	local-if is optional, and defaults to 0.0.0.0
#	remote-port is optional, and defaults to local-port
#	If local-if is "/fd" then local-port refers to descriptor numbers.
#	BUG: No IPv6 addresses can be specified for remote-host currently.
#		(but local-if can be an IPv6 address)
#
# Options:
#	-f	Run in the foreground and do not fork.
#	-t dir	chroot() to this directory
#	-u uid	setuid() to this user
#	-i file	Use data in file as initialization to destination
#	-I num	Like -i, but use data read from descriptor
#	-F rule	Use a filter rule to alter the stream
#	-S rule	Use SSL on various parts of the connection based on rule
#	-T http	Abbreviation for "-F http -S out:http"
#
# Example: portforw 23//remotehost:23
# Example: portforw localhost:5080//remotehost:80
# Example: portforw 80//remotehost
# Example: portforw internal-if:22//localhost
# Example: portforw /fd:0,1//remotehost:8080
# Example: portforw /fd:4//localhost:6000
# Example: portforw -Sin 992//localhost:23
# Example: portforw -Sout localhost:30000//remotehost:992
# Example: portforw -f -Thttp -I3 /fd:0,1//lcproxy:8080
#
#######
# LICENSE and COPYING TERMS:
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# Contact Michael H. Buselli at cosine@cosine.org if you have any
# questions.
#
# $Id: portforw,v 1.8 2007/07/29 15:57:05 cosine Exp $
# Revision 1.8 is portforw version 0.8.

use strict;
use Getopt::Std;
use IO::File;
use IO::Socket;


#
# @server_info: Array of arrays of listening sockets for forwarding
#	[fd_listen, remote_conn_info, cmdline] -OR-
#	['/fd', remote_conn_info, cmdline, fd_src_in, fd_src_out]
#
# @active_forw: Array of arrays of active forwards
#	[fd_src_in, fd_src_out, fd_dst, cmdline,
#	 filter_status, ssl_status, back_buffer]
#
# %filter_rules: Associative array whose keys/values are which filters to use.
#	'http' => 1 : Filter out an HTTP reply header from the forwarded conn.
#
# %ssl_rule: Associative array whose keys/values are which SSL rules to use.
#	'in'  => 1      : Speak SSL on incoming connections.
#	'out' => 1      : Speak SSL on outgoing connections.
#	'out' => 'http' : Start SSL session after an HTTP header is received.
#	'key_file'      : Key value is the private key file ('in' mode only).
#	'cert_file'     : Key value is the certificate file ('in' mode only).
#
my @server_info = ();
my @active_forw = ();
my %filter_rules = ();
my %ssl_rules = ();
my $initialization = '';


# Parse the options.
my %opts = ();
getopts('ft:u:i:I:F:S:T:', \%opts);


# Install signal handlers.
$SIG{HUP} = \&catch_signal;
$SIG{QUIT} = \&catch_signal;
$SIG{INT} = \&catch_signal;
$SIG{TERM} = \&catch_signal;


# Process arguments and open listen ports.
foreach my $arg (@ARGV) {
  my ($localpart, $remotepart) = split(/\s*\/\/\s*/, $arg);

  my ($localif, $localport);
  if ($localpart =~ /^((.+):)?([^:]+)$/) {
    ($localif, $localport) = ($2, $3);
    $localif = '0.0.0.0' if $localif eq '';
  }
  else {
    die "Invalid format for local address: $localpart";
  }

  my ($remotehost, $remoteport);
  if ($remotepart =~ /^([^:]+)(:([^:]+))?$/) {
    ($remotehost, $remoteport) = ($1, $3);
    $remoteport = $localport if $remoteport eq '';
  }
  else {
    die "Invalid format for remote address: $remotepart";
  }

  if ($localif eq '/fd') {
    my $fd_in = new IO::File;

    if ($localport =~ /^(\d+)$/) {
      $fd_in->open("+<&=$1") or die "cannot grab descriptor $1: $!";
      push @server_info,
	  ['/fd', "$remotehost:$remoteport", $arg, $fd_in, $fd_in];
    }

    elsif ($localport =~ /^(\d+),(\d+)$/) {
      my $fd_out = new IO::File;
      $fd_in->open("<&=$1") or die "cannot grab descriptor $1: $!";
      $fd_out->open(">&=$2") or die "cannot grab descriptor $2: $!";
      push @server_info,
	  ['/fd', "$remotehost:$remoteport", $arg, $fd_in, $fd_out];
    }

    else {
      die "Invalid format for local descriptor address: $localpart";
    }
  }

  else {
    my $server = IO::Socket::INET->new(LocalAddr => "$localif:$localport",
				       Proto	 => 'tcp',
				       Type	 => SOCK_STREAM,
				       ReuseAddr => 1,
				       Listen	 => 10)
      or die "Cannot open socket for $arg: $@";

    push @server_info, [$server, "$remotehost:$remoteport", $arg];
  }
}


# Check if we have any open ports.
if (@server_info == 0) {
  print STDERR "Not listening on any sockets, exiting.\n";
  exit 1;
}


# Find out which user/group we need to run as.
my($uid, $gid);
if ($opts{u}) {
  (undef, undef, $uid, $gid) = getpwnam($opts{u})
    or die "Cannot get user information for $opts{u}";
}


# chroot() ourselves if we have -t option.
if ($opts{t}) {
  if ($opts{t} !~ m|^(/.*)$|) {
    print STDERR "Chroot directory must being with a slash, exiting.\n";
  }
  $opts{t} = $1;
  chdir $opts{t} or die "Cannot chdir $opts{t}: $!";
  chroot $opts{t} or die "Cannot chroot $opts{t}: $!";
}


# Now change our uid/gid.
if ($opts{u}) {
  $( = "$gid $gid" or die "setgid: $!";
  $) = "$gid $gid" or die "setegid: $!";
  $< = $uid or die "setuid: $!";
  $> = $uid or die "seteuid: $!";
}


# Read initialization information from file or socket.
if ($opts{i}) {
  my $file = new IO::File;
  $file->open("< $opts{i}") or die "cannot open $opts{i}: $!";
  $initialization .= $_ while <$file>;
  $file->close;
}

if ($opts{I}) {
  my $file = new IO::File;
  $opts{I} += 0;  # coerce this to a number for some safety
  $file->open("<&=$opts{I}") or die "cannot grab descriptor $opts{I}: $!";
  $initialization .= $_ while <$file>;
  $file->close;
}

# Find out our filter rules and SSL rules.  -T is parsed first so that
# it can be overruled with with -F and -S, if present.
if ($opts{T}) {
  # -T http	Abbreviation for "-F http -S out:http"
  if ($opts{T} eq 'http') {
    $filter_rules{'http'} = 1;
    $ssl_rules{'out'} = 'http';
  }
  else {
    die "Invalid argument to -T";
  }
}

if ($opts{F}) {
  my %valid_filters = ('http' => 1);
  split_rules(\%filter_rules, \%valid_filters, $opts{F}, 'filter');
}

if ($opts{S}) {
  my %valid_rules = ('in' => 'full', 'out' => 'full');
  split_rules(\%ssl_rules, \%valid_rules, $opts{S}, 'SSL rule');
}

# Check if IO::Socket::SSL is available if we are going to need it.
if (scalar keys %ssl_rules > 0) {
  eval q{ use IO::Socket::SSL; };
  die $@ if $@;
}


# fork() off as a daemon if all is well.
if (not $opts{f}) {
  my $pid = fork;
  exit 0 if $pid > 0;
  die "Cannot fork: $!" if $pid < 0;
}


# Now officially "open" any already open connections.
my @new_server_info = ();
foreach my $forw (@server_info) {
  if ($forw->[0] eq '/fd') {
    open_new_active_forw($forw, $forw->[3], $forw->[4]);
  }
  else {
    push @new_server_info, $forw;
  }
}
@server_info = @new_server_info;


# Loop until we run out of listeners and active connections.
while (@server_info > 0 or @active_forw > 0) {
  my $readers = '';
  foreach my $forw (@server_info) {
    vec($readers, $forw->[0]->fileno, 1) = 1;
  }
  foreach my $forw (@active_forw) {
    vec($readers, $forw->[0]->fileno, 1) = 1;
    vec($readers, $forw->[2]->fileno, 1) = 1;
  }
  my $errsocks = $readers;

  # Wait for some action.
  select($readers, undef, $errsocks, undef);

  foreach my $forw (@server_info) {
    if (vec($errsocks, $forw->[0]->fileno, 1)) {
      die "Error on socket: $forw->[2]";
    }
    elsif (vec($readers, $forw->[0]->fileno, 1)) {
      my $newin = $forw->[0]->accept;
      open_new_active_forw($forw, $newin, $newin) if $newin;
    }
  }

  my @new_active_forw = ();
  foreach my $forw (@active_forw) {
    if (vec($errsocks, $forw->[2]->fileno, 1) or
	vec($errsocks, $forw->[0]->fileno, 1))
    {
      $forw->[2]->close;
      $forw->[1]->close if $forw->[1] != $forw->[0];
      $forw->[0]->close;
    }

    else {
      my $buf;
      my $keep_alive = 1;

      if (vec($readers, $forw->[0]->fileno, 1)) {
	my $nread = $forw->[0]->sysread($buf, 8192);
	if ($nread == 0) {
	  $forw->[2]->close;
	  $forw->[1]->close if $forw->[1] != $forw->[0];
	  $forw->[0]->close;
	  $keep_alive = 0;
	}
	else {
	  print {$forw->[2]} $buf;
	}
      }

      if ($keep_alive and vec($readers, $forw->[2]->fileno, 1)) {
	my $nread = $forw->[2]->sysread($buf, 8192);
	if ($nread == 0) {
	  $forw->[2]->close;
	  $forw->[1]->close if $forw->[1] != $forw->[0];
	  $forw->[0]->close;
	  $keep_alive = 0;
	}
	else {
          # If the filter/ssl status is 'http' then do some mojo.
          if ($forw->[4] eq 'http' or $forw->[5] eq 'http') {
            my $matchstr = $forw->[6] . $buf;
            my @matchparts = split "\r\n\r\n", $matchstr, 2;

            if (@matchparts > 1) {
              my $pre_match = $matchparts[0] . "\r\n\r\n";
              my $post_match = $matchparts[1];

              # If we are passing data already, then let's pass it now.
              if ($forw->[4] eq 'http') {
                $forw->[4] = undef;  # clear the filter status
              }
              else {
                print {$forw->[1]} substr($pre_match, length($forw->[6]));
              }

              # If we need to SSLize the connection, then let's do it now.
              if ($forw->[5] eq 'http') {
                my $newssl;
                eval q{ $newssl = IO::Socket::SSL::socket_to_SSL($forw->[2]); };
                die $@ if $@;
                if (!$newssl) {
                  print {$forw->[1]} "Cannot initialize SSL client exch: $@\n";
                  $forw->[2]->close;
                  $forw->[1]->close if $forw->[1] != $forw->[0];
                  $forw->[0]->close;
                  $keep_alive = 0;
                }
                $forw->[2] = $newssl;
                $forw->[5] = undef;  # clear the ssl status
              }

              # Now push the rest of the data out.
              print {$forw->[1]} $post_match;
              $forw->[6] = '';  # no longer need the buffer
            }

            # No match -- just pass data if we are supposed to and save buffer.
            else {
              if ($forw->[4] ne 'http') {
                print {$forw->[1]} $buf;
              }
              $forw->[6] = substr($matchstr, -3);  # need last 3 chars.
            }
          }
          else {
            print {$forw->[1]} $buf;
          }
	}
      }

      push @new_active_forw, $forw if $keep_alive;
    }
  }
  @active_forw = @new_active_forw;
}


# Helper function for parsing -F and -S options.
sub split_rules {
  my ($parsed_rules, $valid_rules, $input, $type) = @_;
  my @rules = split(',', $input);
  foreach my $rule (@rules) {
    if ($rule =~ /([^:]*):(.*)/) {
      my ($base, $modifier) = ($1, $2);
      if ($valid_rules->{$base}) {
        $parsed_rules->{$base} = "$modifier";
      }
      else {
        die "Invalid $type option $base";
      }
    }
    else {
      if ($valid_rules->{$rule}) {
        $parsed_rules->{$rule} = $valid_rules->{$rule};
      }
      else {
        die "Invalid $type option $rule";
      }
    }
  }
}


sub open_new_active_forw {
  my ($server, $fd_in, $fd_out) = @_;
  my $filter_status = undef;
  my $ssl_status = undef;

  select $fd_in; $| = 1;
  if ($fd_in != $fd_out) {
    select $fd_out; $| = 1;
  }

  $filter_status = 'http' if $filter_rules{'http'};
  $ssl_status = 'http' if $ssl_rules{'out'} eq 'http';

  if ($ssl_rules{'in'} eq 'full') {
    if ($fd_in != $fd_out) {
      print $fd_out "Cannot SSLize split communications channel\n";
      $fd_out->close;
      $fd_in->close;
      return;
    }
    else {
      my %ssl_options = (SSL_server => 1);
      if (defined $ssl_rules{'key_file'}) {
        $ssl_options{SSL_key_file} = $ssl_rules{'key_file'};
      }
      if (defined $ssl_rules{'cert_file'}) {
        $ssl_options{SSL_cert_file} = $ssl_rules{'cert_file'};
      }

      eval q{ $fd_in = IO::Socket::SSL::socket_to_SSL($fd_in, %ssl_options); };
      die $@ if $@;
      if (!$fd_in) {
        print $fd_out "Cannot initialize SSL server: $@\n";
        $fd_out->close;
        return;
      }
    }
  }

  my $newout = IO::Socket::INET->new(PeerAddr => $server->[1],
				     Proto    => 'tcp',
				     Type     => SOCK_STREAM);
  if ($newout) {
    select $newout; $| = 1;
    if ($ssl_rules{'out'} eq 'full') {
      my $newssl;
      eval q{ $newssl = IO::Socket::SSL::socket_to_SSL($newout); };
      die $@ if $@;
      if (!$newssl) {
        print $fd_out "Cannot initialize SSL client: $@\n";
        $fd_out->close;
        $fd_in->close;
        $newout->close;
        return;
      }
      $newout = $newssl;
    }

    print $newout $initialization;
    push @active_forw,
         [$fd_in, $fd_out, $newout, $server->[2],
          $filter_status, $ssl_status, ''];
  }
  else {
    print $fd_out "Failed to forward connection to $server->[1]: $@\n";
    $fd_out->close if $fd_out != $fd_in;
    $fd_in->close;
  }
}


sub clean_and_exit {
  foreach my $forw (@active_forw) {
    $forw->[2]->close;
    $forw->[1]->close if $forw->[1] != $forw->[0];
    $forw->[0]->close;
  }
  foreach my $forw (@server_info) {
    $forw->[0]->close;
  }
  exit $_[0];
}


sub catch_signal {
  clean_and_exit 0;
}