#!perl
# a toy SOCKS 5 server

use warnings; use strict; use 5.012; 
use EV;
use AnyEvent; 
use IO::Handle; use Socket;
use AnyEvent::Util qw"fh_nonblocking"; 

$EV::DIED = sub { warn @_; exit 1; };
socket our $S, PF_INET(), SOCK_STREAM(), 0 or die "socket S"; 
setsockopt $S,SOL_SOCKET(),SO_REUSEADDR(),pack("i",1) or die "SO_REUSEADDR S"; 
bind $S, pack_sockaddr_in(1080, INADDR_LOOPBACK()) or die "bind S"; 
listen $S,1 or die "listen S"; 
say "listening S"; 
fh_nonblocking $S,1;
our $mna = 0;
our $ws = AE::io $S, 0, sub {

	my $na = $mna++;
	my $din = accept my$A,$S or die "accept A,S: $!"; 
	$A->autoflush; 
	fh_nonblocking $A, 0;
	my($pin,$ain) = unpack_sockaddr_in $din; 
	warn "accepted A[$na] from remote host " . inet_ntoa($ain) . " port " . $pin; 
	read $A, my$m0, 2 or die "read A m1: $!"; 
	my($sve, $nau) = unpack "CC", $m0; 
	5 == $sve or die "wrong socks version magic: $sve"; 
	read $A, my$m1, $nau or die "read A m1"; 
	my @wau = unpack"C*",$m1; 
	print $A pack"CC", 5, 0 or die "print A authentication method reply"; 
	read $A, my$m2, 4 or die "read A m2"; 
	my($_sve, $cmd, $_res, $adt)=unpack "CCCC", $m2; 
	1 == $cmd or die "wrong socks command (1=connect, 2=bind, 3=udp_assoc): " . $cmd; 
	1 == $adt or die "wrong address type (1=inet, 3=domainname, 4=inet6): " . $adt; 
	read $A, my$m3, 4+2 or die "read A m3"; 
	my($oa, $op) = unpack "A4n", $m3; 
	say "wants connect O[$na] to host " . inet_ntoa($oa) . " port " . $op; 
	my $dsz = 2**12;

	socket my $O, PF_INET(),SOCK_STREAM(),0 or die "socket O"; 
	$O->autoflush;
	fh_nonblocking $O, 1;
	connect $O, pack_sockaddr_in($op,$oa);

	my $wc;
	$wc = AE::io $O, 1, sub {

		$wc = undef;
		length(my $r = getsockopt $O, SOL_SOCKET(), SO_ERROR()) or warn "error SO_ERROR O[$na]: $!";
		my $e = unpack "i", $r;
		if ($e) {
			say "error connect O[$na] to host " . inet_ntoa($oa) . " port " . $op . " : " . ($! = $e);
			print $A pack "CCCCx4x2", 5,5,0,1 or die "print A error reply";
			return;
		}
		say "connect O[$na] to host " . inet_ntoa($oa) . " port " . $op . " ok";
		printflush $A pack "CCCCx4x2", 5,0,0,1 or die "print A success reply";
		
		my $wa;
		$wa = AE::io $A, 0, sub {
			fh_nonblocking $A, 1;
			my $r = sysread $A, my$b, 2**14;
			if (0 < $r) {
				my $d = $b;
				$d =~ y/\x00-\x1f\x7f-\xff/|/;
				my $dp = 0 <= ($dsz -= length $d);
				say "read A[$na] $r bytes " . ($dp ? "($d)" : "");
				fh_nonblocking $O, 0;
				printflush $O $b or die "print O[$na] data";
				say "wrote O[$na] $r bytes";
			} else {
				say "eof A[$na] " . (defined($r) ? "" : $!);
				$wa = undef;
				shutdown $O, 1;
			}
		};
		
		my $wo;
		$wo = AE::io $O, 0, sub {
			fh_nonblocking $O, 1;
			my $r = sysread $O, my$b, 2**14;
			if (0 < $r) {
				say "read O[$na] $r bytes";
				fh_nonblocking $A, 0;
				printflush $A $b or die "print A[$na] data";
				say "wrote A[$na] $r bytes";
			} else {
				say "eof O[$na] " . (defined($r) ? "" : $!);
				$wo = undef;
				shutdown $A, 1;
			}
		};

	};
	
};

my $whbeat = AE::timer 10, 10, sub {
	say "heartbeat " . AE::now;
};

EV::run();

__END__