aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2015-09-13 14:04:03 +0200
committerGuilhem Moulin <guilhem@fripost.org>2015-09-13 14:47:07 +0200
commit35ab0d8661b6808a9132bde20eefcf07f1486093 (patch)
tree42ec4983a078aba283bc060ffd7ba24e73c689d4 /lib/Net/IMAP
parenta4729170cffc902319b08bae86e1ab6e20a7939d (diff)
Replace IO::Socket::SSL dependency by the lower level Net::SSLeay.
Also, * Rename the 'SSL_verify_trusted_peer', 'SSL_ca_path', and 'SSL_cipher_list' options to 'SSL_CApath', 'SSL_verify' and 'SSL_cipherlist', respectively. * Add an option 'SSL_CAfile' to specify a file containing trusted certificates to use during server certificate authentication. * Replace Compress::Zlib dependency by the lower level Compress::Raw::Zlib.
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm224
1 files changed, 137 insertions, 87 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 678e09d..c26d102 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -20,16 +20,20 @@ package Net::IMAP::InterIMAP v0.0.2;
use warnings;
use strict;
-use Compress::Zlib qw/Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
+use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
-use Errno 'EWOULDBLOCK';
use IO::Select ();
+use Net::SSLeay ();
use List::Util 'first';
use POSIX ':signal_h';
-use Socket 'SO_KEEPALIVE';
+use Socket qw/SO_KEEPALIVE SOL_SOCKET/;
use Exporter 'import';
BEGIN {
+ Net::SSLeay::load_error_strings();
+ Net::SSLeay::SSLeay_add_ssl_algorithms();
+ Net::SSLeay::randomize();
+
our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/;
}
@@ -51,12 +55,16 @@ my %OPTIONS = (
command => qr/\A(\/\P{Control}+)\z/,
'null-stderr' => qr/\A(YES|NO)\z/i,
compress => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
- SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
- SSL_cipher_list => qr/\A(\P{Control}+)\z/,
- SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
- SSL_ca_path => qr/\A(\P{Control}+)\z/,
+ SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+)\z/,
+ SSL_cipherlist => qr/\A(\P{Control}+)\z/,
+ SSL_verify => qr/\A(YES|NO)\z/i,
+ SSL_CApath => qr/\A(\P{Control}+)\z/,
+ SSL_CAfile => qr/\A(\P{Control}+)\z/,
);
+# Use the same buffer size as Net::SSLeay::read(), to ensure there is
+# never any pending data left in the current TLS record
+my $BUFSIZE = 32768;
#############################################################################
# Utilities
@@ -228,7 +236,7 @@ sub new($%) {
# in/out buffer counts and output stream
$self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0;
$self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
- $self->{_OUTBUF} = '';
+ $self->{_OUTBUF} = undef;
if ($self->{type} eq 'tunnel') {
my $command = $self->{command} // $self->fail("Missing tunnel command");
@@ -277,12 +285,10 @@ sub new($%) {
$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: $!");
$self->_start_ssl($socket) if $self->{type} eq 'imaps';
-
- $socket->sockopt(SO_KEEPALIVE, 1);
$self->{$_} = $socket for qw/STDOUT STDIN/;
}
- $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!");
binmode $self->{$_} foreach qw/STDIN STDOUT/;
# command counter
@@ -396,10 +402,10 @@ sub new($%) {
$self->panic($IMAP_text) unless $r eq 'OK';
if ($algo eq 'DEFLATE') {
- my %args = ( -WindowBits => 0 - MAX_WBITS );
- $self->{_Z_DEFLATE} = Compress::Zlib::deflateInit(%args) //
+ my %args = ( -WindowBits => 0 - MAX_WBITS, -Bufsize => $BUFSIZE );
+ $self->{_Z_DEFLATE} = Compress::Raw::Zlib::Deflate::->new(%args, -AppendOutput => 1) //
$self->panic("Can't create deflation stream");
- $self->{_Z_INFLATE} = Compress::Zlib::inflateInit(%args) //
+ $self->{_Z_INFLATE} = Compress::Raw::Zlib::Inflate::->new(%args) //
$self->panic("Can't create inflation stream");
}
else {
@@ -445,6 +451,9 @@ sub DESTROY($) {
my $self = shift;
$self->{_STATE} = 'LOGOUT';
+ Net::SSLeay::free($self->{_SSL}) if defined $self->{_SSL};
+ Net::SSLeay::CTX_free($self->{_SSL_CTX}) if defined $self->{_SSL_CTX};
+
foreach (qw/STDIN STDOUT/) {
$self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
}
@@ -871,18 +880,17 @@ sub notify($@) {
sub slurp($) {
my $self = shift;
- my $stdout = $self->{STDOUT};
+ my $ssl = $self->{_SSL};
my $read = 0;
while (1) {
- # Unprocessed data within the current SSL frame would cause
+ # Unprocessed data within the current TLS record would cause
# select(2) to block/timeout due to the raw socket not being
# ready.
- unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) {
+ unless (defined $ssl and Net::SSLeay::pending($ssl) > 0) {
my ($ok) = $self->{_SEL_OUT}->can_read(0);
return $read unless defined $ok;
}
-
$self->_resp( $self->_getline() );
$read++;
}
@@ -1180,52 +1188,80 @@ sub push_flag_updates($$@) {
#############################################################################
# Private methods
+# $self->_ssl_error($error, [...])
+# Log an SSL $error and exit with return value 1.
+sub _ssl_error($$) {
+ my $self = shift;
+ $self->log('SSL ERROR: ', @_);
+ if ($self->{debug}) {
+ while (my $err = Net::SSLeay::ERR_get_error()) {
+ $self->log(Net::SSLeay::ERR_error_string($err));
+ }
+ }
+ exit 1;
+}
+
# $self->_start_ssl($socket)
-# Upgrade the $socket to IO::Socket::SSL.
+# Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
my ($self, $socket) = @_;
- require 'IO/Socket/SSL.pm';
- require 'Net/SSLeay.pm';
-
- my %sslargs = (SSL_create_ctx_callback => sub($) {
- my $ctx = shift;
- my $rv;
-
- # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html
- $rv = Net::SSLeay::CTX_get_options($ctx)
- | Net::SSLeay::OP_SINGLE_ECDH_USE()
- | Net::SSLeay::OP_SINGLE_DH_USE()
- | Net::SSLeay::OP_NO_SSLv2()
- | Net::SSLeay::OP_NO_SSLv3()
- | Net::SSLeay::OP_NO_COMPRESSION();
- Net::SSLeay::CTX_set_options($ctx, $rv);
-
- # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html
- $rv = Net::SSLeay::CTX_get_mode($ctx)
- | Net::SSLeay::MODE_AUTO_RETRY() # don't fail SSL_read on renegociation
- | Net::SSLeay::MODE_RELEASE_BUFFERS();
- Net::SSLeay::CTX_set_mode($ctx, $rv);
- });
-
- my $fpr = delete $self->{SSL_fingerprint};
- my $vrfy = delete $self->{SSL_verify_trusted_peer};
- $sslargs{SSL_verify_mode} = ($vrfy // 1) ? Net::SSLeay::VERIFY_PEER() : Net::SSLeay::VERIFY_NONE();
- $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
-
- IO::Socket::SSL->start_SSL($socket, %sslargs)
- or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
-
- # ensure we're talking to the right server
- if (defined $fpr) {
- my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256';
- my $fpr2 = $socket->get_fingerprint($algo);
- $fpr =~ s/.*\$//;
- $fpr2 =~ s/.*\$//;
- $self->fail("Fingerprint don't match! MiTM in action?")
- unless uc $fpr eq uc $fpr2;
+ my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!");
+
+ # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html
+ Net::SSLeay::CTX_set_options($ctx,
+ Net::SSLeay::OP_SINGLE_ECDH_USE() |
+ Net::SSLeay::OP_SINGLE_DH_USE() |
+ Net::SSLeay::OP_NO_SSLv2() |
+ Net::SSLeay::OP_NO_SSLv3() |
+ Net::SSLeay::OP_NO_COMPRESSION() );
+
+ # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html
+ Net::SSLeay::CTX_set_mode($ctx,
+ Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE() |
+ Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER() |
+ Net::SSLeay::MODE_AUTO_RETRY() | # don't fail SSL_read on renegociation
+ Net::SSLeay::MODE_RELEASE_BUFFERS() );
+
+ if (defined (my $ciphers = $self->{SSL_cipherlist})) {
+ Net::SSLeay::CTX_set_cipher_list($ctx, $ciphers)
+ or $self->_ssl_error("Can't set cipher list");
+ }
+
+ if ($self->{SSL_verify} // 1) {
+ # verify the certificate chain
+ my ($file, $path) = ($self->{SSL_CAfile} // '', $self->{SSL_CApath} // '');
+ if ($file ne '' or $path ne '') {
+ Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path)
+ or $self->_ssl_error("Can't load verify locations");
+ }
+ Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER());
+ }
+ else {
+ Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_NONE());
}
+ 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");
+ $self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1;
+
+ if (defined (my $fpr = $self->{SSL_fingerprint})) {
+ # ensure we're talking to the right server
+ (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr);
+ my $digest = pack 'H*', ($fpr =~ tr/://rd);
+
+ my $type = Net::SSLeay::EVP_get_digestbyname($algo)
+ or $self->_ssl_error("Can't find MD value for name '$algo'");
+
+ my $cert = Net::SSLeay::get_peer_certificate($ssl)
+ or $self->_ssl_error("Can't get peer certificate");
+
+ $self->fail("Fingerprint doesn't match! MiTM in action?")
+ if Net::SSLeay::X509_digest($cert, $type) ne $digest and
+ Net::SSLeay::X509_pubkey_digest($cert, $type) ne $digest;
+ }
+
+ @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx);
}
@@ -1239,24 +1275,31 @@ sub _getline($;$) {
my $self = shift;
my $len = shift // 0;
- my $stdout = $self->{STDOUT};
+ my ($stdout, $ssl) = @$self{qw/STDOUT _SSL/};
$self->fail("Lost connection") unless $stdout->opened();
my (@lit, @line);
while(1) {
- if ($self->{_OUTBUF} eq '') {
+ unless (defined $self->{_OUTBUF}) {
+ my ($buf, $n);
# nothing cached: read some more
- # (read at most 2^14 bytes, the maximum length of an SSL
- # frame, to ensure to guaranty that there is no pending data)
- my $n = $stdout->sysread(my $buf,16384,0);
+ if (defined $ssl) {
+ ($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE);
+ } else {
+ $n = $stdout->sysread($buf, $BUFSIZE, 0);
+ }
+
$self->panic("Can't read: $!") unless defined $n;
$self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
$self->{_OUTRAWCOUNT} += $n;
if (defined (my $i = $self->{_Z_INFLATE})) {
- $buf = $i->inflate($buf) // $self->panic("Inflation failed: ", $i->msg());
+ $i->inflate($buf, $self->{_OUTBUF}) == Z_OK or
+ $self->panic("Inflation failed: ", $i->msg());
+ }
+ else {
+ $self->{_OUTBUF} = $buf;
}
- $self->{_OUTBUF} = $buf;
}
if ($len == 0) { # read a regular line: stop after the first \r\n
if ((my $idx = 1 + index($self->{_OUTBUF}, "\n")) > 0) {
@@ -1273,20 +1316,19 @@ sub _getline($;$) {
}
else {
push @line, $self->{_OUTBUF};
- $self->{_OUTBUF} = '';
+ undef $self->{_OUTBUF};
}
}
elsif ($len > 0) { # $len bytes of literal bytes to read
- if ($len <= length($self->{_OUTBUF})) {
+ if ($len < length($self->{_OUTBUF})) {
push @lit, substr($self->{_OUTBUF}, 0, $len, '');
$len = 0;
}
else {
push @lit, $self->{_OUTBUF};
$len -= length($self->{_OUTBUF});
- $self->{_OUTBUF} = '';
+ undef $self->{_OUTBUF};
}
- next;
}
}
}
@@ -1314,7 +1356,7 @@ sub _update_cache_for($$%) {
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.")
+ "Need to invalidate the UID cache.")
if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
$self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v;
}
@@ -1327,12 +1369,18 @@ sub _update_cache_for($$%) {
# Send the given @data to the IMAP server.
# Update the interal raw byte count, but the regular byte count must
# have been updated earlier (eg, by _send_cmd).
-sub _write($@) {
- my $self = shift;
- foreach (@_) {
- next if $_ eq '';
- $self->{STDIN}->write($_) // $self->panic("Can't write: $!");
- $self->{_INRAWCOUNT} += length($_);
+sub _write($$) {
+ my ($self, $data) = @_;
+ my ($stdin, $ssl) = @$self{qw/STDIN _SSL/};
+
+ my ($offset, $length) = (0, length($$data));
+ while ($length > 0) {
+ my $written = defined $ssl ?
+ Net::SSLeay::write_partial($ssl, $offset, $length, $$data) :
+ $stdin->syswrite($$data, $length, $offset);
+ $offset += $written;
+ $length -= $written;
+ $self->{_INRAWCOUNT} += $written;
}
}
@@ -1340,10 +1388,11 @@ sub _write($@) {
# $self->_z_flush([$type])
# Flush the deflation stream, and write the compressed data.
# This method is a noop if no compression layer is active.
-sub _z_flush($;$) {
- my ($self,$t) = @_;
- my $d = $self->{_Z_DEFLATE} // return;
- $self->_write( $d->flush($t) // $self->panic("Can't flush deflation stream: ", $d->msg()) );
+sub _z_flush($$;$) {
+ my ($self, $buf, $t) = @_;
+ my $d = $self->{_Z_DEFLATE};
+ $d->flush($buf, $t) == Z_OK or
+ $self->panic("Can't flush deflation stream: ", $d->msg());
}
@@ -1361,6 +1410,7 @@ sub _send_cmd($) {
my ($offset, $litlen) = (0, 0);
my $z_flush = 0; # whether to flush the dictionary after processing the next literal
+ my $buf;
while(1) {
my $lit = substr($command, $offset, $litlen) if $litlen > 0;
$offset += $litlen;
@@ -1383,20 +1433,21 @@ sub _send_cmd($) {
my @data = (($offset == 0 ? "$tag " : $lit), $line, "\r\n");
$self->{_INCOUNT} += length($_) foreach @data;
if (!defined $d) {
- $self->_write(@data);
+ $buf .= join '', @data;
}
else {
for (my $i = 0; $i <= $#data; $i++) {
- $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
- $self->_write( $d->deflate($data[$i]) // $self->panic("Deflation failed: ", $d->msg()) );
- $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
+ $self->_z_flush(\$buf, Z_FULL_FLUSH) if $i == 0 and $z_flush;
+ $d->deflate($data[$i], \$buf) == Z_OK or $self->panic("Deflation failed: ", $d->msg());
+ $self->_z_flush(\$buf, Z_FULL_FLUSH) if $i == 0 and $z_flush;
}
}
if (!$litplus or $idx < 0) {
- $self->_z_flush(Z_SYNC_FLUSH) if defined $d;
+ $self->_z_flush(\$buf, Z_SYNC_FLUSH) if defined $d;
+ $self->_write(\$buf);
+ undef $buf;
- $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
last if $idx < 0;
my $x = $self->_getline();
$x =~ /\A\+ / or $self->panic($x);
@@ -1851,7 +1902,6 @@ sub _resp($$;$$$) {
$x .= "\r\n";
$self->{_INCOUNT} += length($x);
$self->_write($x);
- $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
}
}
else {