From 37ebe331178e2b7d225a31f64463aef5448d4970 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 8 Nov 2019 05:27:36 +0100 Subject: libinterimap: honor compress={Yes/No}. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index bb27009..3d5bdcf 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -61,7 +61,7 @@ my %OPTIONS = ( auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\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/, + compress => qr/\A(YES|NO)\z/i, SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/, SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+)\z/, SSL_cipherlist => qr/\A(\P{Control}+)\z/, -- cgit v1.2.3 From d08ee23dccf56af292a9616986e58cc39386e3fb Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 8 Nov 2019 06:53:19 +0100 Subject: Remove deprecated/buggy 'o' regexp modifier. --- lib/Net/IMAP/InterIMAP.pm | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3d5bdcf..77c1b14 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1408,10 +1408,10 @@ 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 }; + qr/$dec(?:\.$dec){3}/ }; my $RE_IPv6 = do { my $h16 = qr/[0-9A-Fa-f]{1,4}/; - my $ls32 = qr/$h16:$h16|$RE_IPv4/o; + my $ls32 = qr/$h16:$h16|$RE_IPv4/; qr/ (?: $h16 : ){6} $ls32 | :: (?: $h16 : ){5} $ls32 | (?: $h16 )? :: (?: $h16 : ){4} $ls32 @@ -1421,7 +1421,7 @@ my $RE_IPv6 = do { | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32 | (?: (?: $h16 : ){0,5} $h16 )? :: $h16 | (?: (?: $h16 : ){0,6} $h16 )? :: - /xo }; + /x }; # Opens a TCP socket to the given $host and $port. @@ -1429,11 +1429,10 @@ sub _tcp_connect($$$) { my ($self, $host, $port) = @_; my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP); - if ($host =~ qr/\A$RE_IPv4\z/o) { + if ($host =~ qr/\A$RE_IPv4\z/) { $hints{family} = AF_INET; $hints{flags} |= AI_NUMERICHOST; - } - elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/o) { + } elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/) { $host = $1; $hints{family} = AF_INET6; $hints{flags} |= AI_NUMERICHOST; -- cgit v1.2.3 From a7c364bf90a4593cfbc7911b1b7536dc66b1c879 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 10 Nov 2019 05:39:41 +0100 Subject: Test suite: add new tests for SSL/TLS. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit SSL connections are accepted on TCP port 10993. Also, fix STARTTLS directive, broken since fba1c36… --- lib/Net/IMAP/InterIMAP.pm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 77c1b14..b4d8bec 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -215,7 +215,7 @@ sub in_set($$) { return 1 if $x == $1; } elsif ($r eq '*' or $r eq '*:*') { - warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)"; + warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)"; return 1; } elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) { @@ -398,7 +398,8 @@ sub new($%) { if ($self->{type} eq 'imap' and $self->{STARTTLS}) { # RFC 2595 section 5.1 $self->fail("Server did not advertise STARTTLS capability.") unless grep {$_ eq 'STARTTLS'} @caps; - $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps'; + $self->_send('STARTTLS'); + $self->_start_ssl($self->{S}); # refresh the previous CAPABILITY list since the previous one could have been spoofed delete $self->{_CAPABILITIES}; @@ -1610,7 +1611,7 @@ sub _ssl_verify($$$) { my $pkey = Net::SSLeay::X509_get_X509_PUBKEY($cert); unless (defined $pkey and Net::SSLeay::EVP_Digest($pkey, $type) eq $digest) { - $self->warn("Fingerprint doesn't match! MiTM in action?"); + $self->warn("Fingerprint doesn't match! MiTM in action?"); $ok = 0; } } @@ -2355,7 +2356,7 @@ sub _resp($$;&$$) { # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs if ($self->_enabled('QRESYNC')) { $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check - $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled."); + $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled."); } # the new message was expunged before it was synced $self->{_NEW} = 0 if $self->{_NEW} == 1 and $cache->{EXISTS} == $1; @@ -2406,7 +2407,7 @@ sub _resp($$;&$$) { /\A \((\\?$RE_ATOM_CHAR+ [0-9]+(?: \\?$RE_ATOM_CHAR+ [0-9]+)*)?\)\z/ or $self->panic($_); my %status = split / /, $1; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive - $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response") + $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response") if $self->_enabled('QRESYNC') and !defined $status{HIGHESTMODSEQ} and defined $cmd and ($cmd eq 'NOTIFY' or $cmd eq 'slurp'); $self->_update_cache_for($mailbox, %status); -- cgit v1.2.3 From 23046d58204e636880ff4412e52799e0c06065b4 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 11 Nov 2019 00:20:26 +0100 Subject: Bump minimum Perl for Net::IMAP::InterIMAP to v5.20. We're using s///r which was introduced in 5.14, and hash slices which were introduced in 5.20. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index b4d8bec..c25df27 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -17,7 +17,7 @@ #---------------------------------------------------------------------- package Net::IMAP::InterIMAP v0.0.5; -use v5.10.0; +use v5.20.0; use warnings; use strict; -- cgit v1.2.3 From 3aa5593af18bd4925235d1820fd0fe7c646843aa Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 12 Nov 2019 01:39:29 +0100 Subject: Net::IMAP::InterIMAP::push_flag_updates() bugfixes. The UNCHANGEDSINCE test from the CONDSTORE extension was incorrectly placed after the flag list in UID STORE commands. In practice this meant the server didn't add the MODIFIED code when needed. The server won't send an untagged FETCH command (and won't increase the message's MODSEQ) if no change was made to the flag list. A panic() was incorrectly triggered in that case. When the flag list was set (by another client) to a superset of the UID STORE command currently processed, the extra flags were not synchronized. Cf. RFC 7162 sec. 3.1.3 ex. 10. --- lib/Net/IMAP/InterIMAP.pm | 58 ++++++++++++++++++++--------------------------- 1 file changed, 24 insertions(+), 34 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index c25df27..a838dd0 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1197,16 +1197,15 @@ sub pull_updates($;$) { my $mailbox = $self->{_SELECTED} // $self->panic(); my $pcache = $self->{_PCACHE}->{$mailbox}; - my %modified; $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") if $full and ($pcache->{UIDNEXT} // 1) > 1; - my @missing; + my %modified; while (%{$self->{_MODIFIED}}) { + my @missing; while (my ($uid,$v) = each %{$self->{_MODIFIED}}) { - # don't filter on the fly (during FETCH responses) because - # FLAG updates can arrive while processing pull_new_messages - # for instance + # don't filter on the fly (during FETCH responses) because FLAG updates + # can arrive while processing pull_new_messages() for instance if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH next unless $uid < ($pcache->{UIDNEXT} // 1) # out of bounds and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen @@ -1216,8 +1215,9 @@ sub pull_updates($;$) { } } $self->{_MODIFIED} = {}; + # non-empty @missing indicates a discouraged (but allowed) CONDSTORE server behavior, + # cf. RFC 7162 sec. 3.1.3 ex. 8 and the comment in push_flag_updates() below $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; - @missing = (); } # do that afterwards since the UID FETCH command above can produce VANISHED responses @@ -1307,22 +1307,18 @@ sub push_flag_updates($$@) { my $mailbox = $self->{_SELECTED} // $self->panic(); my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic(); - my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; - - my %listed; - $self->_send($command, sub($){ $listed{shift->{UID}}++; }); + my $command = "UID STORE ".compact_set(@set)." (UNCHANGEDSINCE $modseq) FLAGS.SILENT ($flags)"; my %failed; + $self->_send($command); if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { foreach (split /,/, $1) { if (/\A([0-9]+)\z/) { $failed{$1} = 1; - } - elsif (/\A([0-9]+):([0-9]+)\z/) { + } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); $failed{$_} = 1 foreach ($min .. $max); - } - else { + } else { $self->panic($_); } } @@ -1330,34 +1326,28 @@ sub push_flag_updates($$@) { my @ok; foreach my $uid (@set) { + my $modified = $self->{_MODIFIED}; if ($failed{$uid}) { - # $uid was listed in the MODIFIED response code - $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates - delete $self->{_MODIFIED}->{$uid} if - # got a FLAG update for $uid; ignore it if it's $flags - defined $self->{_MODIFIED}->{$uid}->[1] and - $self->{_MODIFIED}->{$uid}->[1] eq $flags; - } - else { - # $uid wasn't listed in the MODIFIED response code - next unless defined $self->{_MODIFIED}->{$uid}; # already stored - $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check - if ($listed{$uid} == 1) { - # ignore succesful update - delete $self->{_MODIFIED}->{$uid}; - } - elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) { - # got multiple FETCH responses for $uid, the last one with $flags - delete $self->{_MODIFIED}->{$uid}; + # $uid was listed in the MODIFIED response code from RFC 7162; will FETCH + # again in pull_updates(); per RFC 7162 sec. 3.1.3 $modified->{$uid} might not + # be defined ("nice" servers send an untagged FETCH response, cf. example 10, + # but they might omit it - allowed but discouraged CONDSTORE server behavior - + # cf. example 8) + $modified->{$uid} //= [ 0, undef ]; + } elsif (defined (my $m = $modified->{$uid})) { + # received an untagged FETCH response, remove from the list of pending changes + # if the flag list was up to date (either implicitely or explicitely) + if (!defined $m->[1] or $m->[1] eq $flags) { + delete $modified->{$uid}; + push @ok, $uid; } - push @ok, $uid; } } unless ($self->{quiet}) { $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok; $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '. - "trying again later") if %failed; + "will try again later") if %failed; } return keys %failed; } -- cgit v1.2.3 From ccf90182d04c064bd9327c5e7067ed4b9dc32f41 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 12 Nov 2019 05:04:45 +0100 Subject: Net::IMAP::InterIMAP: Don't export $IMAP_text and $IMAP_cond. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index a838dd0..e595060 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -36,7 +36,7 @@ BEGIN { Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); - our @EXPORT_OK = qw/xdg_basedir read_config compact_set $IMAP_text $IMAP_cond + our @EXPORT_OK = qw/xdg_basedir read_config compact_set slurp is_dirty has_new_mails/; } -- cgit v1.2.3 From 0a2558aabfefd6800fe74c24e5aff2b0d47cc5e2 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 11 Nov 2019 00:39:09 +0100 Subject: Avoid sending large UID EXPUNGE|FETCH|STORE and APPEND commands. UID EXPUNGE|FETCH|STORE commands are now split into multiple (sequential) commands when their set representation exceeds 4096 bytes in size. Without splitting logic set representations could grow arbitrarily large, and exceed the server's maximum command size. This adds roundtrips which could be eliminated by pipelining, but it's unlikely to make any difference in typical synchronization work. While set representations seem to remain small in practice, they might grow significantly if many non-contiguous UIDs were flagged and/or expunged, and later synchronized at once. Furthermore, for MULTIAPPEND-capable servers, the number of messages is limited to 128 per APPEND command (also subject to a combined literal size of 1MiB like before). These numbers are currently not configurable. They're intentionally lower than Dovecot's default maximum command size (64k) in order to avoid a deadlock situation after sending 8k-long commands under COMPRESS=DEFLATE: https://dovecot.org/pipermail/dovecot/2019-November/117522.html . --- lib/Net/IMAP/InterIMAP.pm | 64 +++++++++++++++++++++++++++++++---------------- 1 file changed, 43 insertions(+), 21 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index e595060..02ae65f 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -203,6 +203,21 @@ sub compact_list(@) { return $set; } +# with_set($set, $cmd) +# Split long commands over multiple subsets to avoid exceeding the server limit +sub with_set($&) { + my ($set, $cmd) = @_; + my $max_length = 4096; + for (my $length = length($set); $length > $max_length;) { + my $l = rindex($set, ',', $max_length); + die unless $l > 0; # sanity check + $cmd->(substr($set, 0, $l)); + $set = substr($set, ++$l); + $length -= $l; + } + return $cmd->($set); +} + # in_set($x, $set) # Return true if the UID or sequence number $x belongs to the set $set. @@ -841,9 +856,10 @@ sub remove_message($@) { $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") unless $self->_capable('UIDPLUS'); - my $set = compact_set(@set); - $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)"); - $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS + with_set(compact_set(@set), sub($) { + $self->_send("UID STORE $_[0] +FLAGS.SILENT (\\Deleted)"); + $self->_send("UID EXPUNGE $_[0]"); # RFC 4315 UIDPLUS + }); my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; @@ -960,7 +976,9 @@ sub append($$@) { # optional $callback. sub fetch($$$;&) { my ($self, $set, $flags, $callback) = @_; - $self->_send("UID FETCH $set $flags", $callback); + return with_set($set, sub($) { + $self->_send("UID FETCH $_[0] $flags", $callback); + }); } @@ -1217,7 +1235,9 @@ sub pull_updates($;$) { $self->{_MODIFIED} = {}; # non-empty @missing indicates a discouraged (but allowed) CONDSTORE server behavior, # cf. RFC 7162 sec. 3.1.3 ex. 8 and the comment in push_flag_updates() below - $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; + with_set(compact_set(@missing), sub($) { + $self->_send("UID FETCH $_[0] (MODSEQ FLAGS)") + }) if @missing; } # do that afterwards since the UID FETCH command above can produce VANISHED responses @@ -1279,7 +1299,7 @@ sub pull_new_messages($$&@) { $range .= "$since:4294967295"; $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); # sanity check - $self->_send("UID FETCH $range ($attrs)", sub($) { + $self->fetch($range, "($attrs)", sub($) { my $mail = shift; $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID}; $callback->($mail) if defined $callback; @@ -1307,22 +1327,23 @@ sub push_flag_updates($$@) { my $mailbox = $self->{_SELECTED} // $self->panic(); my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic(); - my $command = "UID STORE ".compact_set(@set)." (UNCHANGEDSINCE $modseq) FLAGS.SILENT ($flags)"; my %failed; - $self->_send($command); - if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { - foreach (split /,/, $1) { - if (/\A([0-9]+)\z/) { - $failed{$1} = 1; - } elsif (/\A([0-9]+):([0-9]+)\z/) { - my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); - $failed{$_} = 1 foreach ($min .. $max); - } else { - $self->panic($_); + with_set(compact_set(@set), sub($) { + $self->_send("UID STORE $_[0] (UNCHANGEDSINCE $modseq) FLAGS.SILENT ($flags)"); + if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { + foreach (split /,/, $1) { + if (/\A([0-9]+)\z/) { + $failed{$1} = 1; + } elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); + $failed{$_} = 1 foreach ($min .. $max); + } else { + $self->panic($_); + } } } - } + }); my @ok; foreach my $uid (@set) { @@ -1360,8 +1381,9 @@ sub push_flag_updates($$@) { sub silent_store($$$@) { my $self = shift; my $set = shift; - my $mod = shift; - $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")"); + my $subcmd = shift . "FLAGS.SILENT"; + my $flags = join(' ', @_); + with_set($set, sub($) { $self->_send("UID STORE $_[0] $subcmd ($flags)") }); } @@ -1374,7 +1396,7 @@ sub expunge($$) { $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") unless $self->_capable('UIDPLUS'); - $self->_send("UID EXPUNGE $set"); + with_set($set, sub($) { $self->_send("UID EXPUNGE $_[0]") }); } -- cgit v1.2.3