aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm120
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';
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 04:30:40 +0000