From cc842e127d380255524ee8ccf465d63596b2a870 Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem@fripost.org>
Date: Mon, 14 Sep 2015 21:11:56 +0200
Subject: Replace IO::Socket::INET dependency by the lower lever Socket to
enable IPv6.
---
lib/Net/IMAP/InterIMAP.pm | 70 ++++++++++++++++++++++++++++++++++++++---------
1 file changed, 57 insertions(+), 13 deletions(-)
(limited to 'lib')
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 57f002e..0762b3b 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/SO_KEEPALIVE SOL_SOCKET/;
+use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP/;
use Exporter 'import';
BEGIN {
@@ -45,8 +45,8 @@ my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;
# Map each option to a regexp validating its values.
my %OPTIONS = (
- host => qr/\A([0-9a-zA-Z:.-]+)\z/,
- port => qr/\A([0-9]+)\z/,
+ host => qr/\A(\P{Control}+)\z/,
+ port => qr/\A(\P{Control}+)\z/,
type => qr/\A(imaps?|tunnel)\z/,
STARTTLS => qr/\A(YES|NO)\z/i,
username => qr/\A([\x01-\x7F]+)\z/,
@@ -283,13 +283,11 @@ sub new($%) {
}
}
else {
- require 'IO/Socket/INET.pm';
- my %args = (Proto => 'tcp', Blocking => 1);
- $args{PeerHost} = $self->{host} // $self->fail("Missing option host");
- $args{PeerPort} = $self->{port} // $self->fail("Missing option port");
-
- my $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
- $socket->setsockopt(SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
+ foreach (qw/host port/) {
+ $self->fail("Missing option $_") unless defined $self->{$_};
+ }
+ my $socket = $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';
$self->{$_} = $socket for qw/STDOUT STDIN/;
@@ -459,6 +457,7 @@ sub DESTROY($) {
Net::SSLeay::free($self->{_SSL}) if defined $self->{_SSL};
Net::SSLeay::CTX_free($self->{_SSL_CTX}) if defined $self->{_SSL_CTX};
+ shutdown($self->{STDIN}, 2) if $self->{type} ne 'tunnel' and defined $self->{STDIN};
foreach (qw/STDIN STDOUT/) {
$self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
}
@@ -1212,6 +1211,51 @@ sub _ssl_error($$@) {
}
+# RFC 3986 appendix A
+my $RE_IPv4 = do {
+ my $dec = qr/[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5]/;
+ qr/$dec(?:\.$dec){3}/o };
+my $RE_IPv6 = do {
+ my $h16 = qr/[0-9A-Fa-f]{1,4}/;
+ my $ls32 = qr/$h16:$h16|$RE_IPv4/o;
+ qr/ (?: $h16 : ){6} $ls32
+ | :: (?: $h16 : ){5} $ls32
+ | (?: $h16 )? :: (?: $h16 : ){4} $ls32
+ | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
+ | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
+ | (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32
+ | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
+ | (?: (?: $h16 : ){0,5} $h16 )? :: $h16
+ | (?: (?: $h16 : ){0,6} $h16 )? ::
+ /xo };
+
+
+# Opens a TCP socket to the given $host and $port.
+sub _tcp_connect($$$) {
+ my ($self, $host, $port) = @_;
+
+ my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP);
+ if ($host =~ qr/\A$RE_IPv4\z/o) {
+ $hints{family} = AF_INET;
+ $hints{flags} |= AI_NUMERICHOST;
+ }
+ elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/o) {
+ $host = $1;
+ $hints{family} = AF_INET6;
+ $hints{flags} |= AI_NUMERICHOST;
+ }
+
+ my ($err, @res) = Socket::getaddrinfo($host, $port, \%hints);
+ $self->fail("Can't getaddrinfo: $err") if $err ne '';
+
+ foreach my $ai (@res) {
+ socket my $s, $ai->{family}, $ai->{socktype}, $ai->{protocol};
+ return $s if defined $s and connect($s, $ai->{addr});
+ }
+ $self->fail("Can't connect to $host:$port");
+}
+
+
# $self->_start_ssl($socket)
# Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
@@ -1252,7 +1296,7 @@ sub _start_ssl($$) {
}
my $ssl = Net::SSLeay::new($ctx) or $self->fail("Can't create new SSL structure");
- Net::SSLeay::set_fd($ssl, $socket->fileno()) or $self->fail("SSL filehandle association failed");
+ Net::SSLeay::set_fd($ssl, fileno $socket) or $self->fail("SSL filehandle association failed");
$self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1;
if (defined (my $fpr = $self->{SSL_fingerprint})) {
@@ -1296,7 +1340,7 @@ sub _getline($;$) {
if (defined $ssl) {
($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE);
} else {
- $n = $stdout->sysread($buf, $BUFSIZE, 0);
+ $n = sysread($stdout, $buf, $BUFSIZE, 0);
}
$self->_ssl_error("Can't read: $!") unless defined $n;
@@ -1495,7 +1539,7 @@ sub _cmd_flush($;$$) {
while ($length > 0) {
my $written = defined $ssl ?
Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) :
- $stdin->syswrite($self->{_INBUF}, $length, $offset);
+ syswrite($stdin, $self->{_INBUF}, $length, $offset);
$self->_ssl_error("Can't write: $!") unless defined $written and $written > 0;
$offset += $written;
--
cgit v1.2.3
From 9a2a5edacc95c630d37d1215b0c7c938f82b998d Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem@fripost.org>
Date: Tue, 15 Sep 2015 02:10:55 +0200
Subject: Add the ability to proxy TCP connections through a SOCKSv5 proxy.
---
lib/Net/IMAP/InterIMAP.pm | 143 +++++++++++++++++++++++++++++++++++++++++-----
1 file changed, 129 insertions(+), 14 deletions(-)
(limited to 'lib')
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;
--
cgit v1.2.3