#!/usr/bin/perl -w
# $Id: proxy.perl,v 1.14 2000/11/03 21:59:03 rcaputo Exp $

# NTLM-aware proxy, since noone else seems to be.
# Waider April 2001

use strict;

use Socket;
use MIME::Base64;
use Crypt::ECB;
use Digest::MD4;
use Getopt::Long;
use POE qw(Wheel::ListenAccept Wheel::ReadWrite Driver::SysRW Filter::Stream
           Wheel::SocketFactory
          );
                                        # serial number for logging connections
my $log_id = 0;

                                        # Location of logfile
# Redirections are in the form:
#  listen_address:listen_port-connect_address:connect_port
my @redirects = ();
my $proxy = "";

# This stuff should really be determined as much on the fly as
# possible, with the exception of DOMAIN. Although we could look for a local
# SAMBA installation and grab the workgroup from that.
my $host = `hostname`; # This may have to be a valid PC name.
chomp( $host );
$host =~ s/\..*$//;
my $domain = '';
my $user = $ENV{'LOGNAME'};
my $LOG = $ENV{'HOME'} . "/tmp/proxy-$host.log";

GetOptions( 'domain:s' => \$domain, 'proxy:s' => \$proxy );

die "Need a domain\nStopped " unless $domain;
die "Need a proxy\nStopped " unless $proxy;

push @redirects, "0.0.0.0:8080-$proxy"; # ugly

# hack hack. This should work by converting Auth: NTLM to Auth: Basic and
# passing the proxy-auth request back to the connector.
print "What's the password for $user? ";
`stty -echo`;
my $passwd = <>;
`stty echo`;
chomp( $passwd );
print "\n";

print "forking...\n";
if ( fork() != 0 ) {
  exit;
}

open( LOG, ">>$LOG" ) || warn "Failed to open $LOG: $!";
#*LOG = *STDERR;
select( LOG ); $|= 1; select( STDOUT );

###############################################################################
# This is a stream-based proxy session.  It passes data between two
# sockets, and that's about all.

#------------------------------------------------------------------------------
# Create a proxy session to take over the connection.

sub session_create {
  my ($handle, $peer_host, $peer_port, $remote_addr, $remote_port) = @_;

  POE::Session->new( _start         => \&session_start,
                     _stop          => \&session_stop,
                     client_input   => \&session_client_input,
                     client_error   => \&session_client_error,
					 client_flush   => \&session_client_flush,
                     server_connect => \&session_server_connect,
                     server_input   => \&session_server_input,
                     server_error   => \&session_server_error,
					 server_flush   => \&session_server_flush,

                     # ARG0, ARG1, ARG2, ARG3, ARG4
                     [ $handle, $peer_host, $peer_port,
                       $remote_addr, $remote_port
                     ]
                   );
}

#------------------------------------------------------------------------------
# Accept POE's standard _start event.  Try to establish the client
# side of the proxy session.

sub session_start {
  my ($heap, $socket, $peer_host, $peer_port, $remote_addr, $remote_port) =
    @_[HEAP, ARG0, ARG1, ARG2, ARG3, ARG4];

  $heap->{'log'} = ++$log_id;

  $peer_host = inet_ntoa($peer_host);
  print LOG scalar( localtime( time )) . "[$heap->{'log'}] Accepted connection from $peer_host:$peer_port\n";

  $heap->{peer_host} = $peer_host;
  $heap->{peer_port} = $peer_port;
  $heap->{remote_addr} = $remote_addr;
  $heap->{remote_port} = $remote_port;

  $heap->{state} = 'connecting';
  $heap->{queue} = [];

  # Authorization state
  $heap->{auth} = 0;

  # Handle queued data properly
  $heap->{server_data_remaining} = 0;
  $heap->{client_data_remaining} = 0;
  $heap->{server_closed} = 0;
  $heap->{client_closed} = 0;

  $heap->{wheel_client} = POE::Wheel::ReadWrite->new
    ( Handle     => $socket,
      Driver     => POE::Driver::SysRW->new,
      Filter     => POE::Filter::Stream->new,
      InputState => 'client_input',
      ErrorState => 'client_error',
	  FlushedState => 'client_flush',
    );

  $heap->{wheel_server} = POE::Wheel::SocketFactory->new
    ( RemoteAddress  => $remote_addr,
      RemotePort     => $remote_port,
      SuccessState   => 'server_connect',
      FailureState   => 'server_error',
	  FlushedState   => 'server_flush',
    );
}

#------------------------------------------------------------------------------
# Stop the session, and remove all wheels.

sub session_stop {
  my $heap = $_[HEAP];

  print LOG scalar( localtime( time )) . "[$heap->{'log'}] Closing redirection session\n";
  $heap->{auth} = 0;

  delete $heap->{wheel_client};
  delete $heap->{wheel_server};
}

#------------------------------------------------------------------------------
# Received input from the client.  Pass it to the server.

sub session_client_input {
  my ($heap, $input) = @_[HEAP, ARG0];

  if ( !($heap->{auth} )) {
	my $head = $heap->{'client_header'} || "";
	$head .= $input;

	$heap->{'client_header'} = $head;
	if ( $head !~ /^\r$/m ) {
	  return;
	}

	my $body;
	( $head, $body ) = $head =~ m/\A(.*?\n)\r\n(.*)\Z/ms;
	$body ||= "";
	my $greeting = encode_base64( greeting());
	$greeting =~ s/[\r\n]//g;
	$heap->{'saved_header'} = $head;
	$heap->{'saved_body'} = $body;
	$head .= "Proxy-Connection: Keep-Alive\r\n";
	$head .= "Proxy-Authorization: NTLM " . $greeting . "\r\n";
	$input = "$head\r\n$body";
	$heap->{auth}++;
  }

  if ($heap->{state} eq 'connecting') {
    push @{$heap->{queue}}, $input;
  } else {
    (exists $heap->{wheel_server}) && $heap->{wheel_server}->put($input);
  }
  $heap->{server_data_remaining} = 1;
}

#------------------------------------------------------------------------------
# Received an error from the client.  Shut down the connection.

sub session_client_error {
  my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2];

  if ($errnum) {
    print LOG scalar( localtime( time )),
	  " [$heap->{'log'}] Client connection encountered ",
		"$operation error $errnum: $errstr\n";
  }
  else {
    print LOG scalar( localtime( time )),
	  " [$heap->{'log'}] Client closed connection.\n";
	$heap->{auth} = 0;
  }
                                        # stop the wheels
  $heap->{client_closed} = 1;
  if ( !$heap->{server_data_remaining} ) {
	delete $heap->{wheel_client};
	delete $heap->{wheel_server};
  }
}

sub session_client_flush {
  my $heap = $_[HEAP];
  $heap->{client_data_remaining} = 0;
  if ( $heap->{server_closed}) {
	delete $heap->{wheel_client};
	delete $heap->{wheel_server};
  }
}

#------------------------------------------------------------------------------
# The connection to the server has been successfully established.
# Begin passing data through.

sub session_server_connect {
  my ($kernel, $session, $heap, $socket) = @_[KERNEL, SESSION, HEAP, ARG0];

  my ($local_port, $local_addr) = unpack_sockaddr_in(getsockname($socket));
  $local_addr = inet_ntoa($local_addr);
  print LOG scalar( localtime( time )),
	"[$heap->{'log'}] Established forward from local ",
	  "$local_addr:$local_port to remote ",
		$heap->{remote_addr}, ':', $heap->{remote_port}, "\n";

  # It's important here to delete the old server wheel before creating
  # the new one.  Why?  Because otherwise the right side of the assign
  # is evaluated first.  What's this mean?  It means that the
  # ReadWrite wheel's selects get registered, and then the selects get
  # taken away when the SocketFactory is destroyed.  In a nutshell:
  # the ReadWrite never receives select events.

  delete $heap->{wheel_server};

  # It might be cleaner just to have three different wheels in this
  # session, but I originally was trying to be clever.

  $heap->{wheel_server} = POE::Wheel::ReadWrite->new
    ( Handle     => $socket,
      Driver     => POE::Driver::SysRW->new,
      Filter     => POE::Filter::Stream->new,
      InputState => 'server_input',
      ErrorState => 'server_error',
    );

  $heap->{state} = 'connected';
  foreach my $pending (@{$heap->{queue}}) {
    $kernel->call($session, 'client_input', $pending);
  }
  $heap->{queue} = [];
}

#------------------------------------------------------------------------------
# Received input from the server.  Pass it to the client.

sub session_server_input {
  my ($heap, $input) = @_[HEAP, ARG0];

  if ( $heap->{auth} == 1 ) {
	my $head = $heap->{'server_header'} || "";
	$head .= $input;

	$heap->{'server_header'} = $head;
	if ( $head !~ /^\r$/m ) {
	  return;
	}

	my $body;
	( $head, $body ) = $head =~ m/\A(.*)^\r$(.*)\Z/ms;

	# Now look for the auth headers
	my ( $ntlm ) = $head =~ m/Proxy-Authenticate: NTLM (.*)\r$/m;
	if ( defined( $ntlm )) {
	  $ntlm = decode_base64( $ntlm );
	  my $nonce = substr( $ntlm, 8 + 1 + 7 + 2 + 2 + 2 + 2, 8 );

	  #  Do the magic dance
	  my $resp = do_ntlm_magic( $passwd, $nonce );

	  # Need to build a new header
	  my $response = encode_base64( response( $resp ));
	  $response =~ s/[\r\n]//g; # GAH

	  $head = $heap->{'saved_header'};
	  $body = $heap->{'saved_body'};
	  $head .= "Proxy-Connection: Keep-Alive\r\n";
	  $head .= "Proxy-Authorization: NTLM $response\r\n\r\n$body";
	  $heap->{auth}++;

	  $heap->{wheel_server}->put($head);

	  return;
	} else {
	  $heap->{auth} = 0;
	  $input = $head . "\r\n" . $body;
	}
  }

  (exists $heap->{wheel_client}) && $heap->{wheel_client}->put($input);
  $heap->{client_data_remaining} = 1;
}

#------------------------------------------------------------------------------
# Received an error from the server.  Shut down the connection.

sub session_server_error {
  my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2];

  if ($errnum) {
    print LOG scalar( localtime( time )) . "[$heap->{'log'}] Server connection encountered ",
           "$operation error $errnum: $errstr\n"
         ;
  } else {
    print LOG scalar( localtime( time )) . "[$heap->{'log'}] Server closed connection.\n";
  }

  # flag the connection for shutdown
  $heap->{server_closed} = 1;
                                        # stop the wheels
  if ( !$heap->{client_data_remaining} ) {
	delete $heap->{wheel_client};
	delete $heap->{wheel_server};
  }
}

sub session_server_flush {
  my $heap = $_[HEAP];
  $heap->{server_data_remaining} = 0;
  if ( $heap->{client_closed}) {
	delete $heap->{delete_server};
	delete $heap->{wheel_client};
  }
}

###############################################################################
# This is a stream-based proxy server.  It listens on tcp ports, and
# spawns connectors to hop down from the firewall.

sub server_create {
  my ($local_address, $local_port, $remote_address, $remote_port) = @_;

  POE::Session->new( _start         => \&server_start,
                     _stop          => \&server_stop,
                     accept_success => \&server_accept_success,
                     accept_failure => \&server_accept_failure,

                     # ARG0, ARG1, ARG2, ARG3
                     [ $local_address,  $local_port,
                       $remote_address, $remote_port
                     ]
                   );
}

#------------------------------------------------------------------------------
# Start the server.  This records where the server should connect and
# creates the listening socket.

sub server_start {
  my ($heap, $local_addr, $local_port, $remote_addr, $remote_port) =
    @_[HEAP, ARG0, ARG1, ARG2, ARG3];

  print LOG scalar( localtime( time )) . "+ Redirecting $local_addr:$local_port to $remote_addr:$remote_port\n";
                                        # remember the redirect's details
  $heap->{local_addr}  = $local_addr;
  $heap->{local_port}  = $local_port;
  $heap->{remote_addr} = $remote_addr;
  $heap->{remote_port} = $remote_port;
                                        # create a socket factory
  $heap->{server_wheel} = POE::Wheel::SocketFactory->new
    ( BindAddress    => $local_addr,      # bind to this address
      BindPort       => $local_port,      # and bind to this port
      Reuse          => 'yes',            # reuse immediately
      SuccessState   => 'accept_success', # generate this event on connection
      FailureState   => 'accept_failure', # generate this event on error
    );
}

#------------------------------------------------------------------------------
# Accept POE's standard _stop event, and log that the redirection
# server has stopped.

sub server_stop {
  my $heap = $_[HEAP];
  delete $heap->{server_wheel};
  print LOG scalar( localtime( time )) . "- Redirection from $heap->{local_addr}:$heap->{local_port} to ",
         "$heap->{remote_addr}:$heap->{remote_port} has stopped.\n"
       ;
}

#------------------------------------------------------------------------------
# Pass the accepted socket (with peer address information) to the
# session creator, with information about where it should connect.

sub server_accept_success {
  my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0, ARG1, ARG2];
  &session_create( $socket, $peer_addr, $peer_port,
                   $heap->{remote_addr}, $heap->{remote_port}
                 );
}

#------------------------------------------------------------------------------
# The server encountered an error.  Log it, but don't stop.

sub server_accept_failure {
  my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2];

  print LOG scalar( localtime( time )) . "! Redirection from $heap->{local_addr}:$heap->{local_port} to ",
         "$heap->{remote_addr}:$heap->{remote_port} encountered $operation ",
         "error $errnum: $errstr\n"
       ;
}

###############################################################################
# Parse the redirects, and create a server session for each.

foreach my $redirect (@redirects) {
  my ($local_address, $local_port, $remote_address, $remote_port) =
    split(/[-:]+/, $redirect);

  &server_create($local_address, $local_port, $remote_address, $remote_port);
}

$poe_kernel->run();

exit;

sub greeting {
  my $greeting;
  $greeting = "NTLMSSP\0";
  $greeting .= pack( "V", 0x01 ); # message number
  $greeting .= pack( "V", 0xb203 ); # version of some sort
  $greeting .= pack( "v", length( $domain ));
  $greeting .= pack( "v", length( $domain ));
  $greeting .= pack( "V", length( $host ) + 0x20 );
  $greeting .= pack( "v", length( $host ));
  $greeting .= pack( "v", length( $host ));
  $greeting .= pack( "V", 0x20 );
  $greeting .= $host;
  $greeting .= $domain;

  $greeting;
}

sub response {
  my $resp = shift;
  my $data = "";

  $data .= "NTLMSSP\0";
  $data .= pack( "V", 0x03 );
  $data .= pack( "v", 0x18 );
  $data .= pack( "v", 0x18 );
  $data .= pack( "v", 0x40 + length( $domain ) * 2 + length( $user ) * 2 +
				 length( $host ) * 2 );
  $data .= pack( "v", 0x0 );

  $data .= pack( "v", 0x18 );
  $data .= pack( "v", 0x18 );
  $data .= pack( "v", 0x40 + length( $domain ) * 2 + length( $user ) * 2 +
				 length( $host ) * 2 + 0x18 );
  $data .= pack( "v", 0x0 );

  $data .= pack( "v", length( $domain ) * 2 );
  $data .= pack( "v", length( $domain ) * 2 );
  $data .= pack( "v", 0x40 );
  $data .= pack( "v", 0x0 );

  $data .= pack( "v", length( $user ) * 2 );
  $data .= pack( "v", length( $user ) * 2 );
  $data .= pack( "v", 0x40 + length( $domain ) * 2 );
  $data .= pack( "v", 0x0 );

  $data .= pack( "v", length( $host ) * 2 );
  $data .= pack( "v", length( $host ) * 2 );
  $data .= pack( "v", 0x40 + length( $domain ) * 2 + length( $user ) * 2 );
  $data .= pack( "v", 0x0 );
  $data .= pack( "V", 0x0 );

  $data .= pack( "V", 0x40 + length( $domain ) * 2 + length( $user ) * 2 +
				 length( $host ) * 2 + 0x18 + 0x18 );
  $data .= pack( "V", 0x8201 );

  # Fake unicode conversion
  my $d = $domain; $d =~ s/(?<=.)/\0/g;
  $data .= $d;
  my $u = $user; $u =~ s/(?<=.)/\0/g;
  $data .= $u;
  my $h = $host; $h =~ s/(?<=.)/\0/g;
  $data .= $h;

  # add in the magic ingredient
  $data .= $resp;

  $data;
}

# NTLM challenge/response "nonce"ense.
# Note that some of this is a bit wasteful as the password doesn't
# change, but I figure it's useful to have a general-purpose NTLM
# thingy lying around.
sub do_ntlm_magic {
  my ( $passw, $nonce ) = @_;

  # This is the magic string: KGS!@#$%
  # On this shall ye found your encryption. I'm not a cryptographer,
  # and even /I/ know that this should really be "squeamish ossifrage".
  my $magic = "\x4b\x47\x53\x21\x40\x23\x24\x25";

  my $cr = Crypt::ECB->new;
  $cr->cipher( "DES" ) || die $cr->errstring;

  # Hello strong key, let's emasculate you by cutting you down to 14
  # chars and making you all caps. This brings down the potential
  # keyspace considerably, since it treats the following as identical
  # passwords:
  #
  # squeamish ossifrage
  # Squeamish Ossifrage
  # SQUEAMISH OSSI      <--- what they all boil down to
  #
  # I don't know what the valid character range is, either, but I note
  # that the key-generating code, cribbed from elsewhere, cuts off the
  # high bit, meaning you're stuck with low ascii. Assuming it's
  # limited to what you can type on a keyboard, you're talking about
  # 40 non-alpha + 26 alpha = 66, so your keyspace is going to be 66^14
  # possible keys, I guess.
  my $lmpw = uc( substr( $passw . "\x0" x 14, 0, 14 ));

  $cr->key( make_key( substr( $lmpw, 7 )));
  my $lmhpw = $cr->encrypt( $magic );
  $cr->key( make_key( substr( $lmpw, 0, 7 )));
  $lmhpw = $cr->encrypt( $magic ) . $lmhpw . ( "\0" x 5 );

  # fake unicode conversion. I don't know if real conversion is necessary.
  my $ntpw = $passw;
  $ntpw =~ s/(?<=.)/\0/g;
  my $context = new Digest::MD4;
  $context->add( $ntpw );
  my $nthpw = $context->digest . ( "\0" x 5 );

  # Now, we do a silly little dance!
  my $result = "";
  for my $hash ( $lmhpw, $nthpw ) {
	$cr->key( make_key( substr( $hash, 0, 7)));
	$result .= $cr->encrypt( $nonce );
	$cr->key( make_key( substr( $hash, 7, 7)));
	$result .= $cr->encrypt( $nonce );
	$cr->key( make_key( substr( $hash, 14, 7)));
	$result .= $cr->encrypt( $nonce );
  }

  # And that's it.
  $result;
}

# Make a 64-bit parity-coded block from a 56-bit key
sub make_key {
  my $key = shift;
  my $x;
  my $r = unpack( "B*", $key ); # convert to binary
  $r =~ s/(.......)/$1 . (1 - ((($x = $1) =~ tr|1|1|) % 2))/gxe; # gnee
  $r = pack( "B*", $r ); # and back again

  $r;
}