package Net::SOCKS;

# Copyright (c) 1997-1998 Clinton Wong. All rights reserved.
# This program is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself. 

use strict;
use vars qw($VERSION @ISA @EXPORT);
use IO::Socket;
use Carp;

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();

$VERSION = '0.03';

# Status code exporter adapted from HTTP::Status by Gisle Aas.
# Please note - users of this module should not use hard coded numbers
#               in their programs.  Always use the SOCKS_ version of
#               the status code, which are the descriptions below
#               converted to uppercase and _ replacing dash and SPACE.

my %status_code = (
  1  =>   "general SOCKS server failure",        # SOCKS5
  2  =>   "connection not allowed by ruleset",
  3  =>   "network unreachable",
  4  =>   "host unreachable",
  5  =>   "connection refused",
  6  =>   "TTL expired",
  7  =>   "command not supported",
  8  =>   "address type not supported",
  90 =>   "okay",                                # SOCKS4 
  91 =>   "failed",
  92 =>   "no ident",
  93 =>   "user mismatch", 
  100 =>  "incomplete auth",                    # generic
  101 =>  "bad auth",
  102 =>  "server denies auth method",
  202  => "missing SOCKS server net data",
  203  => "missing peer net data",
  204  => "SOCKS server unavailable",
  205  => "timeout",
  206  => "unsupported protocol version",
  207  => "unsupported address type",
  208  => "hostname lookup failure"
);

my $mnemonic_code = '';
my ($code, $message);
while (($code, $message) = each %status_code) {
  # create mnemonic subroutines
  $message =~ tr/a-z \-/A-Z__/;
  $mnemonic_code .= "sub SOCKS_$message () { $code }\t";
  $mnemonic_code .= "push(\@EXPORT, 'SOCKS_$message');\n";
}
eval $mnemonic_code; # only one eval for speed
die if $@;

sub status_message {
  return undef unless exists $status_code{ $_[0] };
  $status_code{ $_[0] };
}

1;
__END__

=head1 NAME

Net::SOCKS - a SOCKS client class

=head1 SYNOPSIS

 Establishing a connection:

 my $sock = new Net::SOCKS(socks_addr => '192.168.1.3',
                socks_port => 1080,
                user_id => 'the_user',
                user_password => 'the_password',
                force_nonanonymous => 1,
                protocol_version => 5);

 # connect to finger port and request finger information for some_user
 my $f= $sock->connect(peer_addr => '192.168.1.3', peer_port => 79);
 print $f "some_user\n";    # example writing to socket
 while (<$f>) { print }     # example reading from socket
 $sock->close();

 Accepting an incoming connection:

 my $sock = new Net::SOCKS(socks_addr => '192.168.1.3',
                socks_port => 1080,
                user_id => 'the_user',
                user_password => 'the_password',
                force_nonanonymous => 1,
                protocol_version => 5);

 my ($ip, $ip_dot_dec, $port) = $sock->bind(peer_addr => "128.10.10.11",
                        peer_port => 9999);

 $f= $sock->accept();
 print $f "Hi!  Type something.\n";    # example writing to socket
 while (<$f>) { print }                # example reading from socket
 $sock->close();


=head1 DESCRIPTION

 my $sock = new Net::SOCKS(socks_addr => '192.168.1.3',
                socks_port => 1080,
                user_id => 'the_user',
                user_password => 'the_password',
                force_nonanonymous => 1,
                protocol_version => 5);

  To connect to a SOCKS server, specify the SOCKS server's
  hostname, port number, SOCKS protocol version, username, and
  password.  Username and password are optional if you plan
  to use a SOCKS server that doesn't require any authentication.
  If you would like to force the connection to be 
  nonanoymous, set the force_nonanonymous parameter.

 my $f= $sock->connect(peer_addr => '192.168.1.3', peer_port => 79);

 To connect to another machine using SOCKS, use the connect method.
 Specify the host and port number as parameters.

 my ($ip, $ip_dot_dec, $port) = $sock->bind(peer_addr => "192.168.1.3",
                        peer_port => 9999);

  If you wanted to accept a connection with SOCKS, specify the host
  and port of the machine you expect a connection from.  Upon
  success, bind() returns the ip address and port number that
  the SOCKS server is listening at on your behalf.

 $f= $sock->accept();

  If a call to bind() returns a success status code SOCKS_OKAY,
  a call to the accept() method will return when the peer host
  connects to the host/port that was returned by the bind() method.
  Upon success, accept() returns SOCKS_OKAY.

 $sock->close();

  Closes the connection.

=head1 SEE ALSO

 RFC 1928, RFC 1929.

=head1 AUTHOR

 Clinton Wong, clintdw@netcom.com

=head1 COPYRIGHT

 Copyright (c) 1997-1998 Clinton Wong. All rights reserved.
 This program is free software; you can redistribute it
 and/or modify it under the same terms as Perl itself.

=cut

# constructor new()

# We don't do any parameter error checking here because the programmer
# should be able to get an object back from new().  A croak
# isn't graceful and returning undef isn't descriptive enough.
# Error checking happens when connect() or bind() calls _validate().
# Error messages are retrieved through status_message() and
# param('status_num').

sub new {
  my $class = shift;

  my $self  = {};
  bless $self, $class;

  ${*self}{status_num} = SOCKS_OKAY;
  $self->_import_args(@_);
  $self;
}

# connect() opens a socket through _request() and sends a command
# code of 1 to the SOCKS server.  It returns a reference to a socket
# upon success or undef upon failure.

sub connect {
  my $self = shift;

  if (${*self}{protocol_version}==4) {
    if ( $self->_request(1, @_) == SOCKS_OKAY ) { return ${*self}{fh} }
  } elsif (${*self}{protocol_version}==5) {
    if ( $self->_request5(1, @_) == SOCKS_OKAY ) { return ${*self}{fh} }
  } else {
    ${*self}{status_num} = SOCKS_UNSUPPORTED_PROTOCOL_VERSION;
  }

  return undef;
}


# bind() opens a socket through _request() and sends a command
# code of 2 to the SOCKS server.  Upon success, it returns
# an array of (32 bit IP address, IP address as dotted decimal,
# port number) where the SOCKS server is listening on the
# client's behalf.  Upon failure, return undef.

sub bind {
  my $self = shift;

  if (${*self}{protocol_version}==4) {
    $self->_request(2, @_);
  } elsif (${*self}{protocol_version}==5) {
    $self->_request5(2, @_);
  } else {
    ${*self}{status_num} = SOCKS_UNSUPPORTED_PROTOCOL_VERSION;
  }

  if  (${*self}{status_num} != SOCKS_OKAY) {
    return undef;
  }

  # if we're working with an IPv4 address
  if (${*self}{protocol_version}==4 || (${*self}{protocol_version}==5
	&& defined ${*self}{addr_type} && ${*self}{addr_type}==1)) {

    # if the listen address is zero, assume it is the same as the socks host
    if (defined ${*self}{listen_addr} && ${*self}{listen_addr} == 0) {
      ${*self}{listen_addr} = ${*self}{socks_addr};
    }

    my $dotted_dec = inet_ntoa( pack ("N", ${*self}{listen_addr} ) );
    if (${*self}{status_num}==SOCKS_OKAY) {
      return (${*self}{listen_addr}, $dotted_dec, ${*self}{listen_port})
    } 
  } else {  # not a 32 bit IPv4 address.  FQDN or IPv6 then.
    if (${*self}{addr_type}==4) {                             # IPv6?
      ${*self}{status_num} = SOCKS_UNSUPPORTED_ADDRESS_TYPE;
      return undef;
    }
    if (${*self}{addr_type}==3) {                             # FQDN?
      my $addr = gethostbyname(${*self}{listen_addr});        # -> 32 bit IPv4
      ${*self}{listen_hostname} = ${*self}{listen_addr};
      if (! defined $addr) {
        ${*self}{status_num}=SOCKS_HOSTNAME_LOOKUP_FAILURE;
	return undef;
      }
	
      my $dotted_dec = inet_ntoa( pack ("N", $addr ) );
      return ($addr, $dotted_dec, ${*self}{listen_port})
    }
  }

  return undef;
}

# Upon success, return a reference to a socket.  Otherwise, return undef.

sub accept {
  my ($self) = @_;

  if (${*self}{protocol_version}==4) {
    if ($self->_get_response() == SOCKS_OKAY ) {  return ${*self}{fh} }
  } elsif (${*self}{protocol_version}==5) {
    $self->_get_resp5();
    if (${*self}{status_num} != SOCKS_OKAY) {return undef}

    if (${*self}{addr_type}==4) {                             # IPv6?
      ${*self}{status_num} = SOCKS_UNSUPPORTED_ADDRESS_TYPE;
      return undef;
    }

    if (${*self}{addr_type}==3) {                             # FQDN?
      my $addr = gethostbyname(${*self}{listen_addr});        # -> 32 bit IPv4
      ${*self}{listen_hostname} = ${*self}{listen_addr};
      if (! defined $addr) {
        ${*self}{status_num}=SOCKS_HOSTNAME_LOOKUP_FAILURE;
	return undef;
      }
      ${*self}{listen_addr}=$addr;              # we expect IPv4 to live there
    }

    return ${*self}{fh}
  } else {
    ${*self}{status_num} = SOCKS_UNSUPPORTED_PROTOCOL_VERSION;
  }

  return undef;
}

sub close {
  my ($self) = @_;
  if (defined ${*self}{fh}) {close(${*self}{fh})}
}

# Validate that destination host/port exists

sub _validate {
  my $self = shift;

  # check the method parameters
  unless (defined ${*self}{socks_addr} && length ${*self}{socks_addr}) {
    return ${*self}{status_num} = SOCKS_MISSING_SOCKS_SERVER_NET_DATA;
  }
  unless (defined ${*self}{socks_port} && ${*self}{socks_port} > 0) {
    return ${*self}{status_num} = SOCKS_MISSING_SOCKS_SERVER_NET_DATA;
  }
  unless (defined ${*self}{peer_addr} && length ${*self}{peer_addr}) {
    return ${*self}{status_num} = SOCKS_MISSING_PEER_NET_DATA;
  }
  unless (defined ${*self}{peer_port} && ${*self}{peer_port} > 0) {
    return ${*self}{status_num} = SOCKS_MISSING_PEER_NET_DATA;
  }
  unless (defined ${*self}{protocol_version} &&
          (${*self}{protocol_version}==4 || ${*self}{protocol_version}==5) ) {
    return ${*self}{status_num} = SOCKS_UNSUPPORTED_PROTOCOL_VERSION;
  }

  if (${*self}{protocol_version}==5 && defined ${*self}{user_id} 
     && length(${*self}{user_id})>0 && (! defined ${*self}{user_password}
     || length(${*self}{user_password}) == 0 ) ) {
    return ${*self}{status_num} = SOCKS_INCOMPLETE_AUTH;
  }

  if ( ! defined ${*self}{user_id} ) {  ${*self}{user_id}='' }

  return ${*self}{status_num} = SOCKS_OKAY;
}

sub _request {

  my $self    = shift;
  my $req_num = shift;
  my $rc;

  $self->_import_args(@_);
  $rc=$self->_validate();

  if ($rc != SOCKS_OKAY) { return ${*self}{status_num} = $rc }

  # connect to the SOCKS server
  $rc=$self->_connect();

  if ($rc==SOCKS_OKAY) {

#fixme - check to make sure peer_addr is dotted decimal or do name
#        resolution on it first

    # send the request
    print  { ${*self}{fh} } pack ('CCn', 4, $req_num, ${*self}{peer_port}) .
	inet_aton(${*self}{peer_addr}) . ${*self}{user_id} . (pack 'x');

    # get server response, returns server response code
    return $self->_get_response();
  }
  return ${*self}{status_num} = $rc;
}

# reads response from server, returns status_code, sets object values

sub _get_response {
  my ($self) = @_;
  my $received = '';

  while ( read(${*self}{fh}, $received, 8) && (length($received) < 8) ) {}

  ( ${*self}{vn},  ${*self}{cd}, ${*self}{listen_port},
    ${*self}{listen_addr} ) = unpack 'CCnN', $received;

  return ${*self}{status_num} = ${*self}{cd};
}

sub _request5 {

  my $self    = shift;
  my $req_num = shift;
  my $rc;

  $self->_import_args(@_);
  $rc=$self->_validate();

  if ($rc != SOCKS_OKAY) { return ${*self}{status_num} = $rc }

  # connect to the SOCKS server
  ${*self}{status_num}=$self->_connect();

  if  (${*self}{status_num} != SOCKS_OKAY) {return ${*self}{status_num}}

  # send method request
  $self->_method_request5();
  if  (${*self}{status_num} != SOCKS_OKAY) {return ${*self}{status_num}}

  # get server method response
  $self->_method_response5();
  if  (${*self}{status_num} != SOCKS_OKAY) {return ${*self}{status_num}}

  
  if ( ${*self}{returned_method} == 2) { # username/password needed
    $self->_user_request5();
    if  (${*self}{status_num} != SOCKS_OKAY) {return ${*self}{status_num}}
    $self->_user_response5();
    if  (${*self}{status_num} != SOCKS_OKAY) {return ${*self}{status_num}}
  }

  my $addr_type;
  my $dest_addr;

  if (${*self}{peer_addr} =~ /[a-z][A-Z]/) {    # FQDN?
    $addr_type=3;
    $dest_addr = length(${*self}{peer_addr}) . ${*self}{peer_addr};
  } else {                                      # nope.  Must be dotted-dec.
    $addr_type = 1;
    $dest_addr = inet_aton(${*self}{peer_addr});
  }

  print  { ${*self}{fh} } pack ('CCCC', 5, $req_num, 0, $addr_type);
  print  { ${*self}{fh} } $dest_addr . pack('n', ${*self}{peer_port});

  $self->_get_resp5();
  return ${*self}{status_num};
}

# reads response from server, returns status_code, sets object values

sub _get_resp5 {
  my ($self) = @_;
  my $received = '';

  while ( read(${*self}{fh}, $received, 4) && (length($received) < 4) ) {}

  ( ${*self}{vn},  ${*self}{cd},  ${*self}{socks_flag}, ${*self}{addr_type})=
  unpack('CCCC', $received);


  if ( ${*self}{addr_type} == 3) {                    # FQDN

    $received = '';
    # get length of hostname (pascal style string)
    while ( read(${*self}{fh}, $received, 1) && (length($received) < 1) ) {}
    my $length = unpack('C', $received);

    $received = '';
    while ( read(${*self}{fh}, $received, $length) && (length($received) <
	    $length) ) {}
    ${*self}{listen_addr} = $received;

  } elsif ( ${*self}{addr_type} == 1) {               # IPv4 32 bit

    $received = '';
    while ( read(${*self}{fh}, $received, 4) && (length($received) < 4) ) {}
     ${*self}{listen_addr}=unpack('N', $received);

  } else {                                            # IPv6, others
    ${*self}{status_num} = SOCKS_UNSUPPORTED_ADDRESS_TYPE;
  }

  $received = '';
  while ( read(${*self}{fh}, $received, 2) && (length($received) < 2) ) {}
  ${*self}{listen_port} = unpack('n', $received);

  if (${*self}{cd} == 0) {
    # convert SOCKS5 success status code into the one SOCKS4 uses
    ${*self}{cd} = SOCKS_OKAY;
  }

  return ${*self}{status_num} = ${*self}{cd};
}

sub _method_request5 {

  my $self    = shift;
  my $method = '';

  # add anonymous to method list if the user didn't specify force_nonanonymous
  if ( !defined ${*self}{force_nonanonymous} ||
       ${*self}{force_nonanonymous}==0) {
    # add anonymous connect to method list
    $method.=pack('C', 0); # anonymous
  }

  if ( defined ${*self}{user_id} && length (${*self}{user_id})>0 ) {
    $method.=pack('C', 2); # user/pass
  }

  if (length($method)==0) {
    return  ${*self}{status_num} = SOCKS_INCOMPLETE_AUTH;
  }

  print { ${*self}{fh} } pack ('CC', 5, length($method)), $method;
  return SOCKS_OKAY;
}

sub _method_response5 {
  my ($self) = @_;
  my $received = '';
  
  while ( read(${*self}{fh}, $received, 2) && (length($received) < 2) ) {}

  my ($ver, $method) = unpack 'CC', $received;
  if ($ver!=5) {return SOCKS_UNSUPPORTED_PROTOCOL_VERSION}
  if ($method==255) {return SOCKS_SERVER_DENIES_AUTH_METHOD}
  ${*self}{returned_method} = $method;
}

# code to send username/password to socks5 server
sub _user_request5 {
  my ($self) = @_;

    # check to make sure the user passed in a user/pass field
    if (! defined ${*self}{user_id} || ! defined ${*self}{user_password} ||
	length(${*self}{user_id}) == 0 ||
	length(${*self}{user_password}) == 0) {
      return ${*self}{status_num} = SOCKS_INCOMPLETE_AUTH;
    }

  print { ${*self}{fh} } pack ('CC', 1, length(${*self}{user_id})),
    ${*self}{user_id}, pack ('C', length(${*self}{user_password})),
    ${*self}{user_password};

  return ${*self}{status_num} = SOCKS_OKAY;
}

sub _user_response5 {
  my ($self) = @_;
  my $received = '';
  
  while ( read(${*self}{fh}, $received, 2) && (length($received) < 2) ) {}

  my ($ver, $status) = unpack 'CC', $received;
  if ($status != 0) {
    return ${*self}{status_num} = SOCKS_BAD_AUTH;
  }
  return ${*self}{status_num} = SOCKS_OKAY;
}

# connect to socks server

sub _connect {
  my ($self) = @_;

  ${*self}{fh} = new IO::Socket::INET (
		   PeerAddr => ${*self}{socks_addr},
		   PeerPort => ${*self}{socks_port},
		   Proto  => 'tcp'
		  ) || return ${*self}{status_num} = SOCKS_FAILED;

  my $old_fh = select(${*self}{fh});
  $|=1;
  select($old_fh);

  return ${*self}{status_num} = SOCKS_OKAY;
}


sub _import_args {
  my $self = shift;
  my (%arg, $key);

  # if a reference was passed, dereference it first
  if (ref($_[0]) eq 'HASH') { %arg = %{$_[0]} } else { %arg = @_ }

  foreach $key (keys %arg) { ${*self}{$key} = $arg{$key} }
}

# get/set an internal variable

# Currently known are:
# socks_addr, socks_port, listen_addr, listen_port,
# peer_addr, peer_port, fh, user_id, vn, cd, status_num.

sub param {
  my ($self, $key, $value) = @_;

  if (! defined $value) {
    # No value given.  We're doing a "get"

    if ( defined ${*self}{$key} ) { return ${*self}{$key} }
    else { return undef }
  }
  
  # Value given.  We're doing a "set"

  ${*self}{$key} = $value;
  return $value;
}

1;