aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changelog7
-rw-r--r--INSTALL8
-rwxr-xr-xinterimap8
-rw-r--r--interimap.163
-rw-r--r--interimap.sample6
-rw-r--r--lib/Net/IMAP/InterIMAP.pm484
6 files changed, 356 insertions, 220 deletions
diff --git a/Changelog b/Changelog
index 754e0fd..e4f1047 100644
--- a/Changelog
+++ b/Changelog
@@ -16,6 +16,13 @@ interimap (0.2) upstream;
and NO_COMPRESSION to the compiled-in CTX options.
* Use SSL_MODE_AUTO_RETRY to avoid SSL_read failures during a
handshake.
+ * 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 IO::Socket::SSL dependency by the lower level Net::SSLeay.
+ * Accept non-fully qualified commands.
-- Guilhem Moulin <guilhem@guilhem.org> Wed, 09 Sep 2015 00:44:35 +0200
diff --git a/INSTALL b/INSTALL
index f27952b..486cdbc 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,6 +1,6 @@
InterIMAP depends on the following Perl modules:
- - Compress::Zlib (core module)
+ - Compress::Raw::Zlib (core module)
- Config::Tiny
- DBI
- DBD::SQLite
@@ -8,8 +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'
- - IO::Socket::SSL for 'type=imaps' (or 'type=imap' and 'STARTTLS=YES')
+ - IO::Socket::INET (core module) for 'type=imap' or 'type=imaps'
+ - Net::SSLeay
- List::Util (core module)
- POSIX (core module)
- Socket (core module)
@@ -18,7 +18,7 @@ InterIMAP depends on the following Perl modules:
On Debian GNU/Linux systems, these modules can be installed with the
following command:
- apt-get install libconfig-tiny-perl libdbi-perl libdbd-sqlite3-perl libio-socket-ssl-perl
+ apt-get install libconfig-tiny-perl libdbi-perl libdbd-sqlite3-perl libnet-ssleay-perl
However Debian GNU/Linux users can also use gbp(1) from git-buildpackage
to build their own package:
diff --git a/interimap b/interimap
index 4a8bde4..e7cd6d5 100755
--- a/interimap
+++ b/interimap
@@ -249,7 +249,7 @@ foreach my $name (qw/local remote/) {
$config{enable} = 'QRESYNC';
$config{name} = $name;
$config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
- $config{'compress'} //= ($name eq 'local' ? 'NO' : 'YES');
+ $config{'compress'} //= ($name eq 'local' ? 0 : 1);
$IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) };
my $client = $IMAP->{$name}->{client};
@@ -514,7 +514,7 @@ sub sync_mailbox_list() {
sync_mailbox_list();
($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
my $ATTRS = 'MODSEQ FLAGS INTERNALDATE '.
- (((!defined $CONF->{_} or uc ($CONF->{_}->{'use-binary'} // 'YES') eq 'YES') and
+ (((!defined $CONF->{_} or $CONF->{_}->{'use-binary'} // 1) and
!$lIMAP->incapable('BINARY') and !$rIMAP->incapable('BINARY'))
? 'BINARY' : 'BODY').'.PEEK[]';
@@ -971,8 +971,8 @@ sub sync_known_messages($$) {
sub callback_new_message($$$$;$$$) {
my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_;
- my $length = defined $mail->{RFC822} ? length($mail->{RFC822})
- : defined $mail->{BINARY} ? length($mail->{BINARY})
+ my $length = defined $mail->{RFC822} ? length(${$mail->{RFC822}})
+ : defined $mail->{BINARY} ? length(${$mail->{BINARY}})
: return; # not for us
if ($length == 0) {
msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})");
diff --git a/interimap.1 b/interimap.1
index 988fa16..7ac8204 100644
--- a/interimap.1
+++ b/interimap.1
@@ -282,33 +282,6 @@ pre\-authenticated connections, depending on the chosen authentication
mechanism.
.TP
-.I SSL_cipher_list
-Cipher list to use for the connection.
-See \fIciphers\fR(1ssl) for the format of such list.
-
-.TP
-.I SSL_fingerprint
-Fingerprint of the server certificate in the form
-\fIALGO\fR$\fIDIGEST_HEX\fR, where \fIALGO\fR is the used algorithm
-(default \(lqsha256\(rq).
-Attempting to connect to a server with a non-matching certificate
-fingerprint causes \fBInterIMAP\fR to abort the connection immediately
-after the SSL/TLS handshake.
-
-.TP
-.I SSL_verify_trusted_peer
-Whether to verify that the peer certificate has been signed by a trusted
-Certificate Authority. Note that using \fISSL_fingerprint\fR to specify
-the fingerprint of the server certificate is orthogonal and does not
-rely on Certificate Authorities.
-(Default: \(lqYES\(rq.)
-
-.TP
-.I SSL_ca_path
-Directory containing the certificate(s) of the trusted Certificate
-Authorities, used for server certificate verification.
-
-.TP
.I compress
Whether to use the IMAP COMPRESS extension [RFC4978] for servers
advertizing it.
@@ -333,6 +306,42 @@ This option is only available in the default section, and is ignored if
either server does not advertize \(lqBINARY\(rq in its capability list.
(Default: \(lqYES\(rq.)
+.TP
+.I SSL_cipher_list
+The cipher list to send to the server. Although the server determines
+which cipher suite is used, it should take the first supported cipher in
+the list sent by the client. See \fBciphers\fR(1ssl) for more
+information.
+
+.TP
+.I SSL_fingerprint
+Fingerprint of the server certificate (or its public key) in the form
+\fIALGO\fR$\fIDIGEST_HEX\fR, where \fIALGO\fR is the used algorithm
+(default \(lqsha256\(rq).
+Attempting to connect to a server with a non-matching certificate
+fingerprint causes \fBInterIMAP\fR to abort the connection immediately
+after the SSL/TLS handshake.
+
+.TP
+.I SSL_verify
+Whether to verify the server certificate chain.
+Note that using \fISSL_fingerprint\fR to specify the fingerprint of the
+server certificate is an orthogonal authentication measure as it ignores
+the CA chain.
+(Default: \(lqYES\(rq.)
+
+.TP
+.I SSL_CApath
+Directory to use for server certificate verification if
+\(lq\fISSL_verify\fR=YES\(rq.
+This directory must be in \(lqhash format\(rq, see \fBverify\fR(1ssl)
+for more information.
+
+.TP
+.I SSL_CAfile
+File containing trusted certificates to use during server certificate
+authentication if \(lq\fISSL_verify\fR=YES\(rq.
+
.SH SUPPORTED EXTENSIONS
Performance is better for servers supporting the following extensions to
diff --git a/interimap.sample b/interimap.sample
index b0f619a..bbf8c42 100644
--- a/interimap.sample
+++ b/interimap.sample
@@ -18,9 +18,9 @@ password = xxxxxxxxxxxxxxxx
#compress = YES
# SSL options
-#SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
+SSL_CApath = /etc/ssl/certs
+#SSL_verify = YES
+#SSL_cipherlist = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
#SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605
-#SSL_verify_trusted_peer = YES
-SSL_ca_path = /etc/ssl/certs
# vim:ft=dosini
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 65a0c10..57f002e 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/;
}
@@ -48,15 +52,20 @@ my %OPTIONS = (
username => qr/\A([\x01-\x7F]+)\z/,
password => qr/\A([\x01-\x7F]+)\z/,
auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
- command => qr/\A(\/\P{Control}+)\z/,
+ 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;
+my $CRLF = "\x0D\x0A";
#############################################################################
# Utilities
@@ -100,7 +109,7 @@ sub read_config($$%) {
die "Invalid option $k\n" unless defined $opts{$k};
next unless defined $conf->{$k};
die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
- $conf->{$k} = $1;
+ $conf->{$k} = $opts{$k} ne qr/\A(YES|NO)\z/i ? $1 : uc $1 eq 'YES' ? 1 : 0;
}
}
return \%configs;
@@ -179,7 +188,9 @@ sub quote($) {
return "\"$str\"";
}
else {
- return "{".length($str)."}\r\n".$str;
+ # we'll later replace the non-synchronizing literal with a
+ # synchronizing one if need be
+ return "{".length($str)."+}$CRLF".$str;
}
}
@@ -221,15 +232,6 @@ sub new($%) {
my $self = { @_ };
bless $self, $class;
- foreach (keys %$self) {
- next unless defined $self->{$_};
- if (uc $self->{$_} eq 'YES') {
- $self->{$_} = 1;
- } elsif (uc $self->{$_} eq 'NO') {
- $self->{$_} = 0;
- }
- }
-
# the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
# (cf RFC 3501 section 3)
$self->{_STATE} = '';
@@ -237,7 +239,8 @@ sub new($%) {
# in/out buffer counts and output stream
$self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0;
$self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
- $self->{_OUTBUF} = '';
+ $self->{_OUTBUF} = $self->{_INBUF} = undef;
+ $self->{_LITPLUS} = '';
if ($self->{type} eq 'tunnel') {
my $command = $self->{command} // $self->fail("Missing tunnel command");
@@ -286,12 +289,11 @@ sub new($%) {
$args{PeerPort} = $self->{port} // $self->fail("Missing option port");
my $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
- $self->_start_ssl($socket) if $self->{type} eq 'imaps';
+ $socket->setsockopt(SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
- $socket->sockopt(SO_KEEPALIVE, 1);
+ $self->_start_ssl($socket) if $self->{type} eq 'imaps';
$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
@@ -405,10 +407,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 {
@@ -454,6 +456,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();
}
@@ -776,21 +781,8 @@ sub append($$@) {
return unless @_;
$self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
unless $self->_capable('UIDPLUS');
-
- my @appends;
- foreach my $mail (@_) {
- my $append = '';
- $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') '
- if defined $mail->{FLAGS};
- $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
- my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, '')
- : defined $mail->{BINARY} ? ($mail->{BINARY}, '~')
- : $self->panic("Missing message body in APPEND");
- $append .= "$t\{".length($body)."\}\r\n".$body;
- push @appends, $append;
- }
$self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.")
- unless $#appends == 0 or $self->_capable('MULTIAPPEND');
+ unless $#_ == 0 or $self->_capable('MULTIAPPEND');
# dump the cache before issuing the command if we're appending to the current mailbox
my ($UIDNEXT, $EXISTS, $cache, %vanished);
@@ -801,7 +793,21 @@ sub append($$@) {
%vanished = map {$_ => 1} @{$self->{_VANISHED}};
}
- $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends));
+ my $tag = $self->_cmd_init('APPEND '.quote($mailbox));
+ foreach my $mail (@_) {
+ my $str = ' ';
+ $str .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' if defined $mail->{FLAGS};
+ $str .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
+ my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, 0)
+ : defined $mail->{BINARY} ? ($mail->{BINARY}, 1)
+ : $self->panic("Missing message body in APPEND");
+ $self->_cmd_extend(\$str);
+ $self->_cmd_extend_lit($body, $t);
+ }
+
+ $self->_cmd_flush();
+ $self->_recv($tag);
+
$IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text);
my ($uidvalidity, $uidset) = ($1, $2);
$self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity);
@@ -819,9 +825,8 @@ sub append($$@) {
$self->panic($_);
}
}
- $self->fail("$uidset contains ".scalar(@uids)." elements while "
- .scalar(@appends)." messages were appended.")
- unless $#uids == $#appends;
+ $self->fail("$uidset contains ".scalar(@uids)." elements while ".($#_+1)." messages were appended.")
+ unless $#uids == $#_;
# if $mailbox is the current mailbox we need to update the cache
if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
@@ -829,12 +834,16 @@ sub append($$@) {
my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}};
delete $vanished2{$_} foreach keys %vanished;
my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile
- $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS;
+ $cache->{EXISTS} += $#_+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS;
$cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT;
}
- $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids))
- unless $self->{quiet};
+ unless ($self->{quiet}) {
+ my $msg = "Added ".($#_+1)." message(s)";
+ $msg .= " to $mailbox" unless defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED};
+ $msg .= ", got new UID ".compact_set(@uids);
+ $self->log($msg);
+ }
return @uids;
}
@@ -880,18 +889,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++;
}
@@ -1189,52 +1197,81 @@ 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->fail(@_) unless defined $self->{_SSL};
+ $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;
+ 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());
+ }
- # 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);
+ 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;
- # 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);
- });
+ 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 $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;
+ my $type = Net::SSLeay::EVP_get_digestbyname($algo)
+ or $self->_ssl_error("Can't find MD value for name '$algo'");
- IO::Socket::SSL->start_SSL($socket, %sslargs)
- or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
+ my $cert = Net::SSLeay::get_peer_certificate($ssl)
+ or $self->_ssl_error("Can't get peer certificate");
- # 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;
+ $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);
}
@@ -1248,24 +1285,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);
- $self->panic("Can't read: $!") unless defined $n;
- $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
+ if (defined $ssl) {
+ ($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE);
+ } else {
+ $n = $stdout->sysread($buf, $BUFSIZE, 0);
+ }
+
+ $self->_ssl_error("Can't read: $!") unless defined $n;
+ $self->_ssl_error("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) {
@@ -1275,27 +1319,26 @@ sub _getline($;$) {
$self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx);
$self->{_OUTCOUNT} += length($lit) + length($line);
- $line =~ s/\r\n\z// or $self->panic($line);
+ $line =~ s/$CRLF\z// or $self->panic($line);
$self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug};
- return (wantarray ? ($lit, $line) : $line);
+ return (wantarray ? (\$lit, $line) : $line);
}
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;
}
}
}
@@ -1323,7 +1366,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;
}
@@ -1332,87 +1375,150 @@ sub _update_cache_for($$%) {
}
-# $self->_write(@data)
-# 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($@) {
+# $self->_cmd_init($command)
+# Generate a new tag for the given $command, push both the
+# concatenation to the command buffer. $command can be a scalar or a
+# scalar reference.
+# Use the _cmd_extend and/or _cmd_extend_lit methods to extend the
+# command, and _cmd_flush to send it to the server.
+sub _cmd_init($$) {
my $self = shift;
- foreach (@_) {
- next if $_ eq '';
- $self->{STDIN}->write($_) // $self->panic("Can't write: $!");
- $self->{_INRAWCOUNT} += length($_);
- }
+ my $tag = sprintf '%06d', $self->{_TAG}++;
+ my $command = (defined $self->{_INBUF} ? $CRLF : '').$tag.' '.(ref $_[0] ? ${$_[0]} : $_[0]);
+ $self->_cmd_extend(\$command);
+ return $tag;
}
-# $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()) );
+# $self->_cmd_extend($args)
+# Append $args to the command buffer. $args can be a scalar or a
+# scalar reference. If $args contains some literal(s) and the server
+# doesn't support LITERAL+, flush the command and wait for an answer
+# before each literal
+sub _cmd_extend($$) {
+ my $self = shift;
+ my $args = ref $_[0] ? $_[0] : \$_[0];
+
+ if ($self->{_LITPLUS} ne '') {
+ # server supports LITERAL+: use $args as is
+ $self->_cmd_extend_($args);
+ }
+ else {
+ # server supports LITERAL+: flush the command before each
+ # literal
+ my ($offset, $litlen) = (0, 0);
+ while ( (my $idx = index($$args, "\n", $offset+$litlen)) >= 0 ) {
+ my $line = substr($$args, $offset, $idx+1-$offset);
+ $line =~ s/\{([0-9]+)\+\}$CRLF\z/{$1}$CRLF/ or $self->panic();
+ $litlen = $1;
+ $self->_cmd_flush(\$line);
+
+ my $x = $self->_getline();
+ $x =~ /\A\+ / or $self->panic($x);
+ $offset = $idx+1;
+ }
+ my $line = substr($$args, $offset);
+ $self->_cmd_extend_(\$line);
+ }
}
-# $self->_send_cmd($tag, $command)
-# Send the given $command to the IMAP server.
-# If $command contains literals and the server supportes LITERAL+,
-# non-synchronizing literals are sent instead.
-# If a compression layer is active, $command is compressed before
-# being send.
-sub _send_cmd($) {
- my ($self, $tag, $command) = @_;
- my $litplus = $self->_capable('LITERAL+') ? 1 : 0;
+# $self->_cmd_extend_lit($lit, [$lit8])
+# Append the literal $lit to the command buffer. $lit must be a
+# scalar reference. If $lit8 is true, a literal8 is sent instead [RFC
+# 3516].
+sub _cmd_extend_lit($$;$) {
+ my ($self, $lit, $lit8) = @_;
+ my $len = length($$lit);
my $d = $self->{_Z_DEFLATE};
- my ($offset, $litlen) = (0, 0);
- my $z_flush = 0; # whether to flush the dictionary after processing the next literal
+ # create a full flush point for long binary literals
+ my $z_flush = ($len > 4096 and !($self->{'use-binary'} // 1 and !$lit8)) ? 1 : 0;
+ $lit8 = $lit8 ? '~' : ''; # literal8, RFC 3516 BINARY
- while(1) {
- my $lit = substr($command, $offset, $litlen) if $litlen > 0;
- $offset += $litlen;
+ my $strlen = $lit8.'{'.$len.$self->{_LITPLUS}.'}'.$CRLF;
- my ($line, $z_flush2);
- my $idx = index($command, "\n", $offset);
- if ($idx < 0) {
- $line = substr($command, $offset);
- }
- else {
- $line = substr($command, $offset, $idx-1-$offset);
- $litlen = $litplus ? ($line =~ s/\{([0-9]+)\}\z/{$1+}/ ? $1 : $self->panic())
- : ($line =~ /\{([0-9]+)\}\z/ ? $1 : $self->panic());
- $z_flush2 = ($litlen > 4096 and # large literal
- ($self->{'use-binary'} // 1 or $line =~ /~\{[0-9]+\}\z/) # literal8, RFC 3516 BINARY
- ) ? 1 : 0;
+ if ($self->{_LITPLUS} ne '') {
+ $self->_cmd_extend_(\$strlen);
+ if ($z_flush and defined $d) {
+ $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK
+ or $self->panic("Can't flush deflation stream: ", $d->msg());
}
- $self->logger('C: ', ($offset == 0 ? "$tag " : '[...]'), $line) if $self->{debug};
+ }
+ else {
+ # server doesn't supports LITERAL+
+ $self->_cmd_flush(\$strlen, ($z_flush ? Z_FULL_FLUSH : ()));
+ my $x = $self->_getline();
+ $x =~ /\A\+ / or $self->panic($x);
+ }
- my @data = (($offset == 0 ? "$tag " : $lit), $line, "\r\n");
- $self->{_INCOUNT} += length($_) foreach @data;
- if (!defined $d) {
- $self->_write(@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->_cmd_extend_($lit);
+ if ($z_flush and defined $d) {
+ $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK
+ or $self->panic("Can't flush deflation stream: ", $d->msg());
+ }
+}
- if (!$litplus or $idx < 0) {
- $self->_z_flush(Z_SYNC_FLUSH) if defined $d;
- $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
- last if $idx < 0;
- my $x = $self->_getline();
- $x =~ /\A\+ / or $self->panic($x);
+# $self->_cmd_flush([$crlf], [$z_flush])
+# Append $crlf (default: $CRLF) to the command buffer, flush the
+# deflation stream by creating a flush point of type $z_flush
+# (default: Z_SYNC_FLUSH) if there is a compression layer, and finally
+# send the command to the server.
+sub _cmd_flush($;$$) {
+ my $self = shift;
+ $self->_cmd_extend_( $_[0] // \$CRLF );
+ my $z_flush = $_[1] // Z_SYNC_FLUSH; # the flush point type to use
+ my ($stdin, $ssl) = @$self{qw/STDIN _SSL/};
+
+ if ($self->{debug}) {
+ # remove $CRLF and literals
+ my ($offset, $litlen) = (0, $self->{_INBUFDBGLEN} // 0);
+ while ( (my $idx = index($self->{_INBUFDBG}, "\n", $offset+$litlen)) >= 0) {
+ my $line = substr($self->{_INBUFDBG}, $offset+$litlen, $idx+1-$offset-$litlen);
+ $line =~ s/$CRLF\z// or $self->panic();
+ $self->logger('C: ', ($litlen > 0) ? '[...]' : '', $line);
+ $litlen = $line =~ /\{([0-9]+)(\+)?\}\z/ ? $1 : 0;
+ $offset = $idx+1;
}
+ $self->panic() if $offset+$litlen < length($self->{_INBUFDBG});
+ undef $self->{_INBUFDBG};
+ $self->{_INBUFDBGLEN} = $litlen;
+ }
+
+ if (defined (my $d = $self->{_Z_DEFLATE})) {
+ $d->flush(\$self->{_INBUF}, $z_flush) == Z_OK
+ or $self->panic("Can't flush deflation stream: ", $d->msg());
+ }
+
+ my ($offset, $length) = (0, length($self->{_INBUF}));
+ while ($length > 0) {
+ my $written = defined $ssl ?
+ Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) :
+ $stdin->syswrite($self->{_INBUF}, $length, $offset);
+ $self->_ssl_error("Can't write: $!") unless defined $written and $written > 0;
- $z_flush = $z_flush2;
- $offset = $idx+1;
+ $offset += $written;
+ $length -= $written;
+ $self->{_INRAWCOUNT} += $written;
+ }
+ undef $self->{_INBUF};
+}
+
+
+# $self->_cmd_extend_($args)
+# Append the scalar reference $args to the command buffer. Usually
+# one should use the higher-level method _cmd_extend as it takes care
+# of literals if the server doesn't support LITERAL+.
+sub _cmd_extend_($$) {
+ my ($self, $args) = @_;
+ $self->{_INCOUNT} += length($$args); # count IMAP traffic
+ $self->{_INBUFDBG} .= $$args if $self->{debug};
+ if (defined (my $d = $self->{_Z_DEFLATE})) {
+ $d->deflate($args, \$self->{_INBUF}) == Z_OK or $self->panic("Deflation failed: ", $d->msg());
+ }
+ else {
+ $self->{_INBUF} .= $$args;
}
}
@@ -1427,15 +1533,31 @@ sub _send_cmd($) {
# In void context, croak unless the server answers with a tagged 'OK'
# response. Otherwise, return the condition status ('OK'/'NO'/'BAD').
sub _send($$;&) {
- my ($self, $command, $callback) = @_;
- my $cmd = $command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $command;
- my $set = $command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
+ my $self = shift;
+ my $command = \$_[0];
+ my $callback = $_[1];
- # send the command; for servers supporting non-synchronizing
- # literals, mark literals as such and then the whole command in one
- # go, otherwise send literals one at a time
- my $tag = sprintf '%06d', $self->{_TAG}++;
- $self->_send_cmd($tag, $command);
+ my $tag = $self->_cmd_init($command);
+ $self->_cmd_flush();
+
+ if (!defined $callback) {
+ $self->_recv($tag);
+ }
+ else {
+ my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command;
+ my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
+ $self->_recv($tag, $callback, $cmd, $set);
+ }
+}
+
+
+# $self->_recv($tag, [$callback, $command, $set])
+# Wait for a tagged response with the given $tag. The $callback, if
+# provided, is used to process each untagged response. $command and
+# $set can further limit the set of responses to apply the callback
+# to.
+sub _recv($$;$&$) {
+ my ($self, $tag, $callback, $cmd, $set) = @_;
my $r;
# wait for the answer
@@ -1588,6 +1710,7 @@ sub _resp_text($$) {
}
elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) {
$self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
+ $self->{_LITPLUS} = (grep { uc $_ eq 'LITERAL+' } @{$self->{_CAPABILITIES}}) ? '+' : '';
}
elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) {
$self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] );
@@ -1648,7 +1771,7 @@ sub _string($$) {
elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
# literal
(my $lit, $$stream) = $self->_getline($1);
- return $lit;
+ return $$lit;
}
else {
$self->panic($$stream);
@@ -1802,14 +1925,14 @@ sub _resp($$;$$$) {
$mail{INTERNALDATE} = $1;
}
elsif (s/\A(?:RFC822|BODY\[\]) //) {
- $mail{RFC822} = $self->_nstring(\$_);
+ $mail{RFC822} = \$self->_nstring(\$_);
}
elsif (s/\ABINARY\[\] //) {
if (s/\A~\{([0-9]+)\}\z//) { # literal8, RFC 3516 BINARY
(my $lit, $_) = $self->_getline($1);
$mail{BINARY} = $lit;
} else {
- $mail{RFC822} = $self->_nstring(\$_);
+ $mail{RFC822} = \$self->_nstring(\$_);
}
}
elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
@@ -1856,11 +1979,8 @@ sub _resp($$;$$$) {
elsif (s/\A\+ //) {
if (defined $callback and $cmd eq 'AUTHENTICATE') {
my $x = $callback->($_);
- $self->logger("C: ", $x) if $self->{debug};
- $x .= "\r\n";
- $self->{_INCOUNT} += length($x);
- $self->_write($x);
- $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
+ $self->_cmd_extend(\$x);
+ $self->_cmd_flush();
}
}
else {
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 02:00:41 +0000