aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm143
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;