From 567fc180a3e76716816ea9af5a066bad2ea8c01a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 10 May 2018 03:35:13 +0200 Subject: Improve ESEARCH response parsing for full RFC 4466 compatibility. --- lib/Net/IMAP/InterIMAP.pm | 51 +++++++++++++++++++++++++++++++++++++---------- 1 file changed, 40 insertions(+), 11 deletions(-) (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3270108..67b3ce5 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -597,7 +597,7 @@ sub incapable($@) { # Issue an UID SEARCH command with the given $criterion. For the "normal" # UID SEARCH command from RFC 3501, return the list of matching UIDs; # for the extended UID SEARCH command from RFC 4731 (ensuring ESEARCH -# capability is the caller's responsibility), return an "UID" +# capability is the caller's responsibility), return an optional "UID" # indicator followed by a hash containing search data pairs. sub search($$) { my ($self, $crit) = @_; @@ -1946,7 +1946,7 @@ sub _send($$;&) { } else { my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 - : $$command =~ /\AUID SEARCH / ? "\"$tag\"" # RFC 4466's tag-string + : $$command =~ /\AUID SEARCH / ? $tag # for RFC 4466's tag-string : undef; $self->_recv($tag, $callback, $cmd, $set); } @@ -2234,6 +2234,21 @@ sub _envelope($$) { return \@envelope; } +# Parse and consume an RFC 4466 tagged-ext-comp plus a trailing parenthesis +sub _tagged_ext_comp($$$) { + my ($self, $stream, $ret) = @_; + my $v = $$stream =~ s/\A\(// ? $self->_tagged_ext_comp(\$_, []) + : $self->_astring(\$_); + push @$ret, $v; + if ($$stream =~ s/\A\)//) { + return $ret; + } elsif ($$stream =~ s/\A //) { + $self->_tagged_ext_comp(\$_, $ret) + } else { + $self->panic($$stream); + } +} + # $self->_resp($buf, [$callback, $cmd, $set] ) # Parse an untagged response line or a continuation request line. # (The trailing CRLF must be removed.) The internal cache is @@ -2288,16 +2303,30 @@ sub _resp($$;&$$) { elsif (/\ASEARCH((?: [0-9]+)*)\z/) { $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH'; } - elsif (defined $set and s/\AESEARCH \(TAG \Q$set\E\)( UID)?//) { - my $uid = $1; - my %ret; # RFC 4731 + elsif (s/\AESEARCH( |\z)/$1/) { + my $tag = $1 if s/\A \(TAG \"($RE_ASTRING_CHAR+)\"\)//; + my $uid = s/\A UID// ? "UID" : undef; + my @ret; while ($_ ne '') { - $self->fail("RFC 4731 violation in ESEARCH response") - # XXX RFC 4466's tagged-ext-comp unsupported - unless s/\A ($RE_ATOM_CHAR+) ([0-9,:]+)//; - $ret{uc $1} = $2; + # RFC 4466 "tagged-ext-label" is a valid RFC 3501 "atom" + s/\A ($RE_ATOM_CHAR+) // or $self->panic(); + my $label = uc($1); + my $value; + if (s/\A([0-9,:]+)//) { + # RFC 4466 tagged-ext-simple + $value = $1; + } elsif (s/\A\(//) { + # RFC 4466 "(" [tagged-ext-comp] ")" + $value = s/\A\)// ? [] : $self->_tagged_ext_comp(\$_, []); + } else { + $self->panic(); + } + # don't use a hash since some extensions might give more + # than one response for a same key + push @ret, $label => $value; } - $callback->($uid, %ret) if defined $callback and $cmd eq 'SEARCH'; + $callback->($uid, @ret) if defined $callback and $cmd eq 'SEARCH' + and defined $set and $set eq $tag; } elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) { my ($delim, $attrs) = ($2, $1); @@ -2306,7 +2335,7 @@ sub _resp($$;&$$) { $self->panic($_) unless $_ eq ''; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive undef $delim if uc $delim eq 'NIL'; - $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim; + $delim =~ s/\A"(.*)"\z/$1/ if defined $delim; $self->_update_cache_for($mailbox, DELIMITER => $delim); $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs); $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST'; -- cgit v1.2.3 From dd7edb8eac0c11fb8168f5028c8b6d8706cc8fdb Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 20 Jan 2019 19:55:33 +0100 Subject: pullimap, interimap: Use $XDG_CONFIG_HOME/$NAME/config as config file. --- lib/Net/IMAP/InterIMAP.pm | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 67b3ce5..7b0a2be 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -22,7 +22,7 @@ use strict; use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); -use Errno 'EINTR'; +use Errno qw/EEXIST EINTR/; use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC/; use Net::SSLeay (); use List::Util qw/all first/; @@ -35,7 +35,7 @@ BEGIN { Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); - our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond + our @EXPORT_OK = qw/xdg_basedir read_config compact_set $IMAP_text $IMAP_cond slurp is_dirty has_new_mails/; } @@ -76,6 +76,35 @@ my $CRLF = "\x0D\x0A"; ############################################################################# # Utilities +# xdg_basedir($xdg_variable, $default, $subdir, $path) +# Return $path if $path is absolute. Otherwise, return +# "$ENV{$xdg_variable}/$subdir/$path" (resp. "~/$default/$subdir/path" +# if the "$xdg_variable" environment variable is not set). +# An error is raised if "$ENV{$xdg_variable}" (resp. "~/$default") is +# not an existing absolute directory. +# If "$ENV{$xdg_variable}/$subdir" doesn't exist, it is created with +# mode 0700. +sub xdg_basedir($$$$) { + my ($xdg_variable, $default, $subdir, $path) = @_; + $path =~ /\A(\p{Print}+)\z/ or die "Insecure $path"; + $path = $1; + return $path if $path =~ /\A\//; + + my $basedir = $ENV{$xdg_variable}; + unless (defined $basedir) { + my @getent = getpwuid($>); + $basedir = $getent[7] ."/". $default; + } + die "No such directory: ", $basedir unless -d $basedir; + $basedir .= "/".$subdir; + $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir"; + $basedir = $1; + unless (mkdir ($basedir, 0700)) { + die "Couldn't create $basedir: $!\n" unless $! == EEXIST; + } + return $basedir ."/". $path; +} + # read_config($conffile, $sections, %opts) # Read $conffile's default section, then each section in the array # reference $section (which takes precedence). %opts extends %OPTIONS @@ -85,9 +114,6 @@ sub read_config($$%) { my $sections = shift; my %opts = (%OPTIONS, @_); - $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile - unless $conffile =~ /\A\//; # relative path - die "No such config file $conffile\n" unless defined $conffile and -f $conffile and -r $conffile; -- cgit v1.2.3 From 452ae91f06bec4c21e7ba7b7bc4309b089f7afe3 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 20 Jan 2019 19:55:58 +0100 Subject: Specify minimum Perl and Net::SSLeay versions. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 7b0a2be..f783ea7 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -24,7 +24,7 @@ use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); use Errno qw/EEXIST EINTR/; use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC/; -use Net::SSLeay (); +use Net::SSLeay 1.73 (); use List::Util qw/all first/; use POSIX ':signal_h'; use Socket qw/SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/; -- cgit v1.2.3 From 522666e8e2556d89c25013ce17d6db49e75443ef Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 21 Jan 2019 23:59:55 +0100 Subject: Net::IMAP::InterIMAP: add support for TLSv1.3 (on recent enough Net::SSLeay). Also, change "SSL_protocols" default value from "!SSLv2 !SSLv3" to "!SSLv2 !SSLv3 !TLSv1 !TLSv1.1". I.e., only enable TLSv1.2 and later, which is the default in Debian's OpenSSL as of 1.1.1-2, cf. https://tracker.debian.org/news/998835/accepted-openssl-111-2-source-into-unstable/ . --- lib/Net/IMAP/InterIMAP.pm | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index f783ea7..3d8bd97 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -45,7 +45,7 @@ my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/; my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; -my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-2])/; +my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-3])/; # Map each option to a regexp validating its values. my %OPTIONS = ( @@ -1599,13 +1599,19 @@ sub _ssl_verify($$$) { return $ok; # 1=accept cert, 0=reject } -my %SSL_proto = ( - 'SSLv2' => Net::SSLeay::OP_NO_SSLv2(), - 'SSLv3' => Net::SSLeay::OP_NO_SSLv3(), - 'TLSv1' => Net::SSLeay::OP_NO_TLSv1(), - 'TLSv1.1' => Net::SSLeay::OP_NO_TLSv1_1(), - 'TLSv1.2' => Net::SSLeay::OP_NO_TLSv1_2() -); +my %SSL_proto; +BEGIN { + sub _append_ssl_proto($$) { + my ($k, $v) = @_; + $SSL_proto{$k} = $v if defined $v; + } + _append_ssl_proto( "SSLv2", eval { Net::SSLeay::OP_NO_SSLv2() } ); + _append_ssl_proto( "SSLv3", eval { Net::SSLeay::OP_NO_SSLv3() } ); + _append_ssl_proto( "TLSv1", eval { Net::SSLeay::OP_NO_TLSv1() } ); + _append_ssl_proto( "TLSv1.1", eval { Net::SSLeay::OP_NO_TLSv1_1() } ); + _append_ssl_proto( "TLSv1.2", eval { Net::SSLeay::OP_NO_TLSv1_2() } ); + _append_ssl_proto( "TLSv1.3", eval { Net::SSLeay::OP_NO_TLSv1_3() } ); +} # $self->_start_ssl($socket) # Upgrade the $socket to SSL/TLS. @@ -1614,7 +1620,7 @@ sub _start_ssl($$) { my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!"); my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE(); - $self->{SSL_protocols} //= q{!SSLv2 !SSLv3}; + $self->{SSL_protocols} //= q{!SSLv2 !SSLv3 !TLSv1 !TLSv1.1}; my ($proto_include, $proto_exclude) = (0, 0); foreach (split /\s+/, $self->{SSL_protocols}) { my $neg = s/^!// ? 1 : 0; @@ -1629,7 +1635,7 @@ sub _start_ssl($$) { $proto_exclude |= $x; } my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto; - $self->log("Disabling SSL protocol: ".join(', ', sort @proto_exclude)) if $self->{debug}; + $self->log("Disabling SSL protocols: ".join(', ', sort @proto_exclude)) if $self->{debug}; $ssl_options |= $SSL_proto{$_} foreach @proto_exclude; $ssl_options |= Net::SSLeay::OP_NO_COMPRESSION(); @@ -1675,6 +1681,7 @@ sub _start_ssl($$) { $v == 0x0301 ? 'TLSv1' : $v == 0x0302 ? 'TLSv1.1' : $v == 0x0303 ? 'TLSv1.2' : + $v == 0x0304 ? 'TLSv1.3' : '??'), $v)); $self->log(sprintf('SSL cipher: %s (%d bits)' -- cgit v1.2.3 From e85db0b140eb2c56fa46231829a1bfe6f98ede7d Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 20 Jan 2019 20:29:58 +0100 Subject: Bump version number. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3d8bd97..8280fb2 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -16,7 +16,7 @@ # along with this program. If not, see . #---------------------------------------------------------------------- -package Net::IMAP::InterIMAP v0.0.3; +package Net::IMAP::InterIMAP v0.0.4; use warnings; use strict; -- cgit v1.2.3 From 64dd58fb503c5ee31da3bcbe52313c723730a122 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 20 Jan 2019 20:42:56 +0100 Subject: Bump copyright years. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 8280fb2..a773f08 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1,6 +1,6 @@ #---------------------------------------------------------------------- # A minimal IMAP4 client for QRESYNC-capable servers -# Copyright © 2015 Guilhem Moulin +# Copyright © 2015-2018 Guilhem Moulin # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by -- cgit v1.2.3