Add the ability to proxy TCP connections through a SOCKSv5 proxy.

1 files changed, 129 insertions, 14 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 0762b3b..6f44879 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -26,7 +26,7 @@ use IO::Select ();
 use Net::SSLeay ();
 use List::Util 'first';
 use POSIX ':signal_h';
-use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP/;
+use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/;
 
 use Exporter 'import';
 BEGIN {
@@ -47,6 +47,7 @@ my $RE_TEXT_CHAR    = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;
 my %OPTIONS = (
     host => qr/\A(\P{Control}+)\z/,
     port => qr/\A(\P{Control}+)\z/,
+    proxy => qr/\A(\P{Control}+)\z/,
     type => qr/\A(imaps?|tunnel)\z/,
     STARTTLS => qr/\A(YES|NO)\z/i,
     username => qr/\A([\x01-\x7F]+)\z/,
@@ -286,7 +287,8 @@ sub new($%) {
         foreach (qw/host port/) {
             $self->fail("Missing option $_") unless defined $self->{$_};
         }
-        my $socket = $self->_tcp_connect(@$self{qw/host port/});
+        my $socket = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/})
+                                            : $self->_tcp_connect(@$self{qw/host port/});
         setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
 
         $self->_start_ssl($socket) if $self->{type} eq 'imaps';
@@ -494,19 +496,21 @@ sub logger($@) {
 }
 
 
-# $self->warn($warning, [...])
+# $self->warn([$type,] $warning)
 #   Log a $warning.
-sub warn($$@) {
-    my $self = shift;
-    $self->log('WARNING: ', @_);
+sub warn($$;$) {
+    my ($self, $msg, $t) = @_;
+    $msg = defined $t ? "$msg WARNING: $t" : "WARNING: $msg";
+    $self->log($msg);
 }
 
 
-# $self->fail($error, [...])
+# $self->fail([$type,] $error)
 #   Log an $error and exit with return value 1.
-sub fail($$@) {
-    my $self = shift;
-    $self->log('ERROR: ', @_);
+sub fail($$;$) {
+    my ($self, $msg, $t) = @_;
+    $msg = defined $t ? "$msg ERROR: $t" : "ERROR: $msg";
+    $self->log($msg);
     exit 1;
 }
 
@@ -926,8 +930,8 @@ sub set_cache($$%) {
     while (my ($k, $v) = each %status) {
         if ($k eq 'UIDVALIDITY') {
             # try to detect UIDVALIDITY changes early (before starting the sync)
-            $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v)  ",
-                         "Need to invalidate the UID cache.")
+            $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v)  ".
+                        "Need to invalidate the UID cache.")
                 if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
         }
         $cache->{$k} = $v;
@@ -1245,7 +1249,7 @@ sub _tcp_connect($$$) {
         $hints{flags} |= AI_NUMERICHOST;
     }
 
-    my ($err, @res) = Socket::getaddrinfo($host, $port, \%hints);
+    my ($err, @res) = getaddrinfo($host, $port, \%hints);
     $self->fail("Can't getaddrinfo: $err") if $err ne '';
 
     foreach my $ai (@res) {
@@ -1255,6 +1259,117 @@ sub _tcp_connect($$$) {
     $self->fail("Can't connect to $host:$port");
 }
 
+sub _xwrite($$$) {
+    my $self = shift;
+    my ($offset, $length) = (0, length $_[1]);
+
+    while ($length > 0) {
+        my $n = syswrite($_[0], $_[1], $length, $offset);
+        $self->fail("Can't write: $!") unless defined $n and $n > 0;
+        $offset += $n;
+        $length -= $n;
+    }
+}
+
+
+sub _xread($$$) {
+    my ($self, $fh, $length) = @_;
+    my $offset = 0;
+    my $buf;
+    while ($length > 0) {
+        my $n = sysread($fh, $buf, $length, $offset) // $self->fail("Can't read: $!");
+        $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
+        $offset += $n;
+        $length -= $n;
+    }
+    return $buf;
+}
+
+
+# $self->_proxify($proxy, $host, $port)
+#   Initiate the given $proxy to proxy TCP connections to $host:$port.
+sub _proxify($$$$) {
+    my ($self, $proxy, $host, $port) = @_;
+    $port = getservbyname($port, 'tcp') // $self->fail("Can't getservbyname $port")
+        unless $port =~ /\A[0-9]+\z/;
+
+    $proxy =~ /\A([A-Za-z0-9]+):\/\/(\P{Control}*\@)?($RE_IPv4|\[$RE_IPv6\]|[^:]+)(:[A-Za-z0-9]+)?\z/
+        or $self->fail("Invalid proxy URI $proxy");
+    my ($proto, $userpass, $proxyhost, $proxyport) = ($1, $2, $3, $4);
+    $userpass =~ s/\@\z// if defined $userpass;
+    $proxyport = defined $proxyport ? $proxyport =~ s/\A://r : 1080;
+
+    my $socket = $self->_tcp_connect($proxyhost, $proxyport);
+    if ($proto eq 'socks5' or $proto eq 'socks5h') {
+        my $resolv = $proto eq 'socks5h' ? 1 : 0;
+        my $v = 0x05; # RFC 1928  VER protocol version
+
+        my %mech = ( ANON => 0x00 );
+        $mech{USERPASS} = 0x02 if defined $userpass;
+
+        $self->_xwrite($socket, pack('CCC*', 0x05, scalar (keys %mech), values %mech));
+        my ($v2, $m) = unpack('CC', $self->_xread($socket, 2));
+        $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2;
+
+        %mech = reverse %mech;
+        my $mech = $mech{$m} // '';
+        if ($mech eq 'USERPASS') { # RFC 1929 Username/Password Authentication for SOCKS V5
+            my $v = 0x01; # current version of the subnegotiation
+            my ($u, $pw) = split /:/, $userpass, 2;
+
+            $self->_xwrite($socket, pack('C2', $v,length($u)).$u.pack('C',length($pw)).$pw);
+            my ($v2, $r) = unpack('C2', $self->_xread($socket, 2));
+            $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2;
+            $self->fail('SOCKSv5', 'Authentication failed') unless $r == 0x00;
+        }
+        elsif ($mech ne 'ANON') { # $m == 0xFF
+            $self->fail('SOCKSv5', 'No acceptable authentication methods');
+        }
+
+        if ($host !~ /\A(?:$RE_IPv4|\[$RE_IPv6\])\z/ and !$resolv) {
+            # resove the hostname $host locally
+            my ($err, @res) = getaddrinfo($host, undef, {socktype => SOCK_RAW});
+            $self->fail("Can't getaddrinfo: $err") if $err ne '';
+            ($host) = first { defined $_ } map {
+                my ($err, $ipaddr) = getnameinfo($_->{addr}, NI_NUMERICHOST, NIx_NOSERV);
+                $err eq '' ? $ipaddr : undef
+            } @res;
+            $self->fail("Can't getnameinfo") unless defined $host;
+        }
+
+        # send a CONNECT command (CMD 0x01)
+        my ($typ, $addr) =
+            $host =~ /\A$RE_IPv4\z/                                      ? (0x01, Socket::inet_pton(AF_INET, $host))
+          : ($host =~ /\A\[($RE_IPv6)\]\z/ or $host =~ /\A($RE_IPv6)\z/) ? (0x04, Socket::inet_pton(AF_INET6, $1))
+          :                                                                (0x03, pack('C',length($host)).$host);
+        $self->_xwrite($socket, pack('C4', $v, 0x01, 0x00, $typ).$addr.pack('n', $port));
+
+        ($v2, my $r, my $rsv, $typ) = unpack('C4', $self->_xread($socket, 4));
+        $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2 and $rsv == 0x00;
+        my $err = $r == 0x00 ? undef
+                : $r == 0x01 ? 'general SOCKS server failure'
+                : $r == 0x02 ? 'connection not allowed by ruleset'
+                : $r == 0x03 ? 'network unreachable'
+                : $r == 0x04 ? 'host unreachable'
+                : $r == 0x05 ? 'connection refused'
+                : $r == 0x06 ? 'TTL expired'
+                : $r == 0x07 ? 'command not supported'
+                : $r == 0x08 ? 'address type not supported'
+                : $self->panic();
+        $self->fail('SOCKSv5', $err) if defined $err;
+
+        my $len = $typ == 0x01 ? 4
+                : $typ == 0x03 ? unpack('C', $self->_xread($socket, 1))
+                : $typ == 0x04 ? 16
+                : $self->panic();
+        $self->_xread($socket, $len + 2); # consume (and ignore) the rest of the response
+        return $socket;
+    }
+    else {
+        $self->error("Unsupported proxy protocol $proto");
+    }
+}
+
 
 # $self->_start_ssl($socket)
 #   Upgrade the $socket to SSL/TLS.
@@ -1409,7 +1524,7 @@ sub _update_cache_for($$%) {
     while (my ($k, $v) = each %status) {
         if ($k eq 'UIDVALIDITY') {
             # try to detect UIDVALIDITY changes early (before starting the sync)
-            $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v)  ",
+            $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v)  ".
                         "Need to invalidate the UID cache.")
                 if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
             $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v;