diff options
| -rw-r--r-- | Changelog | 5 | ||||
| -rw-r--r-- | INSTALL | 3 | ||||
| -rwxr-xr-x | interimap | 1 | ||||
| -rw-r--r-- | interimap.1 | 14 | ||||
| -rw-r--r-- | interimap.sample | 7 | ||||
| -rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 207 |
6 files changed, 204 insertions, 33 deletions
@@ -11,7 +11,6 @@ interimap (0.2) upstream; Can be disabled by adding 'use-binary=NO' to the default section in the configuration file. * Exit with return value 0 when receiving a SIGTERM. - * Print IMAP traffic stats when receiving a SIGHUP. * Add SSL options SINGLE_ECDH_USE, SINGLE_DH_USE, NO_SSLv2, NO_SSLv3 and NO_COMPRESSION to the compiled-in CTX options. * Use SSL_MODE_AUTO_RETRY to avoid SSL_read failures during a @@ -23,6 +22,10 @@ interimap (0.2) upstream; certificates to use during server certificate authentication. * Replace IO::Socket::SSL dependency by the lower level Net::SSLeay. * Accept non-fully qualified commands. + * Replace IO::Socket::INET dependency by the lower lever Socket to enable + IPv6. (Both are core Perl module.) + * Add a configuration option 'proxy' to proxy TCP connections to the + IMAP server. -- Guilhem Moulin <guilhem@guilhem.org> Wed, 09 Sep 2015 00:44:35 +0200 @@ -8,9 +8,8 @@ InterIMAP depends on the following Perl modules: - Getopt::Long (core module) - MIME::Base64 (core module) if authentication is required - IO::Select (core module) - - IO::Socket::INET (core module) for 'type=imap' or 'type=imaps' - - Net::SSLeay - List::Util (core module) + - Net::SSLeay - POSIX (core module) - Socket (core module) - Time::HiRes (core module) if 'logfile' is set @@ -120,7 +120,6 @@ sub cleanup() { } $SIG{INT} = sub { msg(undef, $!); cleanup(); exit 1; }; $SIG{TERM} = sub { cleanup(); exit 0; }; -$SIG{HUP} = sub { $_->stats() foreach grep defined, ($lIMAP, $rIMAP); }; ############################################################################# diff --git a/interimap.1 b/interimap.1 index 7ac8204..621d968 100644 --- a/interimap.1 +++ b/interimap.1 @@ -255,6 +255,16 @@ Server port. \fItype\fR=imaps.) .TP +.I proxy +An optional SOCKS proxy to use for TCP connections to the IMAP server +(\fItype\fR=imap and \fItype\fR=imaps only), formatted as +\(lq\fIprotocol\fR://[\fIuser\fR:\fIpassword\fR@]\fIproxyhost\fR[:\fIproxyport\fR]\(rq. +If \fIproxyport\fR is omitted, it is assumed at port 1080. +Only SOCKSv5 is supported, in two flavors: \(lqsocks5://\(rq to resolve +\fIhostname\fR locally, and \(lqsocks5h://\(rq to let the proxy resolve +\fIhostname\fR. + +.TP .I command Command to use for \fItype\fR=tunnel. Must speak the IMAP4rev1 protocol on its standard output, and understand it on its standard input. @@ -384,8 +394,8 @@ currently supported. .IP \[bu] \fBInterIMAP\fR will probably not work with non RFC-compliant servers. In particular, no work-around are currently implemented beside the -tunable in the configuration file. Morever, few IMAP servers have been -tested so far. +tunables in the \fBCONFIGURATION FILE\fR. Morever, few IMAP servers +have been tested so far. .SH AUTHOR Written by Guilhem Moulin diff --git a/interimap.sample b/interimap.sample index bbf8c42..5d9d6d2 100644 --- a/interimap.sample +++ b/interimap.sample @@ -1,4 +1,4 @@ -# database = imap.guilhem.org.db +#database = imap.guilhem.org.db #list-mailbox = "*" list-select-opts = SUBSCRIBED ignore-mailbox = ^virtual/ @@ -10,9 +10,10 @@ command = /usr/lib/dovecot/imap null-stderr = YES [remote] -# type = imaps +#type = imaps host = imap.guilhem.org -# port = 993 +#port = 993 +#proxy = socks5h://localhost:9050 username = guilhem password = xxxxxxxxxxxxxxxx #compress = YES diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 57f002e..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/SO_KEEPALIVE SOL_SOCKET/; +use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/; use Exporter 'import'; BEGIN { @@ -45,8 +45,9 @@ 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/, + 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/, @@ -283,13 +284,12 @@ 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 = 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'; $self->{$_} = $socket for qw/STDOUT STDIN/; @@ -459,6 +459,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(); } @@ -495,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; } @@ -927,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; @@ -1212,6 +1215,162 @@ 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) = 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"); +} + +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. sub _start_ssl($$) { @@ -1252,7 +1411,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 +1455,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; @@ -1365,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; @@ -1495,7 +1654,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; |