diff options
author | Guilhem Moulin <guilhem@fripost.org> | 2019-01-22 12:14:46 +0100 |
---|---|---|
committer | Guilhem Moulin <guilhem@fripost.org> | 2019-01-22 12:14:46 +0100 |
commit | df6bf1c10b29464b579b83944aae1cce67a082b5 (patch) | |
tree | e5f62256b4c15d4ed3db80d65d7d228cad04ca1d /lib/Net/IMAP/InterIMAP.pm | |
parent | 18c5d6aec9e9dab83e96edeb8890e8cd9ef63b66 (diff) | |
parent | 41a6694c6d0582c7fffd682926e964ff3fa39b7b (diff) |
Merge tag 'upstream/0.4' into debian
Upstream version 0.4
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 120 |
1 files changed, 91 insertions, 29 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3270108..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 <guilhem@fripost.org> +# Copyright © 2015-2018 Guilhem Moulin <guilhem@fripost.org> # # 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 @@ -16,15 +16,15 @@ # along with this program. If not, see <http://www.gnu.org/licenses/>. #---------------------------------------------------------------------- -package Net::IMAP::InterIMAP v0.0.3; +package Net::IMAP::InterIMAP v0.0.4; use warnings; 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 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/; @@ -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/; } @@ -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 = ( @@ -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; @@ -597,7 +623,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) = @_; @@ -1573,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. @@ -1588,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; @@ -1603,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(); @@ -1649,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)' @@ -1946,7 +1979,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 +2267,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 +2336,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 +2368,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'; |