#!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_REUSE
+ADDR 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) . " por
+t " . $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 repl
+y"; 
    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_as
+soc): " . $cmd; 
    1 == $adt or die "wrong address type (1=inet, 3=domainname, 4=inet
+6): " . $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 war
+n "error SO_ERROR O[$na]: $!";
        my $e = unpack "i", $r;
        if ($e) {
            say "error connect O[$na] to host " . inet_ntoa($oa) . " p
+ort " . $op . " : " . ($! = $e);
            print $A pack "CCCCx4x2", 5,5,0,1 or die "print A error re
+ply";
            return;
        }
        say "connect O[$na] to host " . inet_ntoa($oa) . " port " . $o
+p . " 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__
[download]