aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changelog27
-rw-r--r--INSTALL4
-rw-r--r--README8
-rwxr-xr-xinterimap71
-rw-r--r--interimap.md21
-rw-r--r--interimap.sample2
-rw-r--r--interimap.service2
-rw-r--r--lib/Net/IMAP/InterIMAP.pm120
-rwxr-xr-xpullimap69
-rw-r--r--pullimap.md28
10 files changed, 230 insertions, 122 deletions
diff --git a/Changelog b/Changelog
index f2fee83..5a9074a 100644
--- a/Changelog
+++ b/Changelog
@@ -1,14 +1,29 @@
-interimap (0.4) UNRELEASED
+interimap (0.4) upstream;
* pullimap: replace non RFC 5321-compliant envelope sender addresses
- (received by the IMAP FETCH ENVELOPE command) by the null sender address
+ (received by the IMAP FETCH ENVELOPE command) with the null address
<>.
+ * pullimap, interimap: take configuration filename (default: "config")
+ relative to $XDG_CONFIG_HOME/$NAME (or ~/.config/$NAME), to comply
+ with the XDG specification. Thus the previous default config file
+ $XDG_CONFIG_HOME/$NAME should become $XDG_CONFIG_HOME/$NAME/config.
+ * Library: add support for TLSv1.3 (on recent enough Net::SSLeay), and
+ change "SSL_protocols" default value from "!SSLv2 !SSLv3" to "!SSLv2
+ !SSLv3 !TLSv1 !TLSv1.1".
+ Library: new API idle_start() and idle_stop().
+ Add support for untagged ESEARCH responses from RFC 4731.
+ + pullimap: Use extended SEARCH commands (RFC 4731) if supported by
+ the server to search old mail and EXPUNGE them.
+ + pullimap, interimap: don't autocreate statefile or database in
+ long-lived mode (when --watch or --idle is set). Instead, an error
+ is raised if the statefile or database doesn't exist.
- Ensure the lower bound of UID ranges is at least 1.
- Fix manpage generation with pandoc >=2.1.
+ - Specify minimum Perl and Net::SSLeay versions.
+ - interimap.service: use --watch=60 rather than --notify, because
+ dovecot's NOTIFY extension doesn't seem to work so well as of 2.2.27.
- -- Guilhem Moulin <guilhem@guilhem.org> Tue, 06 Dec 2016 17:37:01 +0100
+ -- Guilhem Moulin <guilhem@fripost.org> Sun, 20 Jan 2019 20:30:08 +0100
interimap (0.3) upstream;
@@ -31,7 +46,7 @@ interimap (0.3) upstream;
- interimap: when resuming a sync, only consider UIDs greater than a
known UIDNEXT.
- -- Guilhem Moulin <guilhem@guilhem.org> Thu, 01 Dec 2016 14:37:50 +0100
+ -- Guilhem Moulin <guilhem@fripost.org> Thu, 01 Dec 2016 14:37:50 +0100
interimap (0.2) upstream;
@@ -65,10 +80,10 @@ interimap (0.2) upstream;
* Display source UIDs upon APPEND. Previously only target UIDs where
displayed in non-debug mode.
- -- Guilhem Moulin <guilhem@guilhem.org> Wed, 09 Sep 2015 00:44:35 +0200
+ -- Guilhem Moulin <guilhem@fripost.org> Wed, 09 Sep 2015 00:44:35 +0200
interimap (0.1) upstream;
* Initial public release. Development was started in July 2015.
- -- Guilhem Moulin <guilhem@guilhem.org> Mon, 07 Sep 2015 17:14:42 +0200
+ -- Guilhem Moulin <guilhem@fripost.org> Mon, 07 Sep 2015 17:14:42 +0200
diff --git a/INSTALL b/INSTALL
index 458b7c2..69afb26 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,4 +1,4 @@
-InterIMAP depends on the following Perl modules:
+InterIMAP depends on Perl >=5.20 and the following Perl modules:
- Compress::Raw::Zlib (core module)
- Config::Tiny
@@ -8,7 +8,7 @@ InterIMAP depends on the following Perl modules:
- Getopt::Long (core module)
- MIME::Base64 (core module) if authentication is required
- List::Util (core module)
- - Net::SSLeay
+ - Net::SSLeay >=1.73
- POSIX (core module)
- Socket (core module)
- Time::HiRes (core module) if 'logfile' is set
diff --git a/README b/README
index 6c3ae34..06f328f 100644
--- a/README
+++ b/README
@@ -1,6 +1,6 @@
InterIMAP is a fast bidirectional synchronization program for QRESYNC-capable
IMAP4rev1 servers. PullIMAP retrieves messages a remote IMAP mailbox and
-deliver them to a SMTP session. Consult the manuals for more information.
+deliver them to an SMTP session. Consult the manuals for more information.
https://guilhem.org/man/interimap.1.html
https://guilhem.org/man/pullimap.1.html
@@ -52,7 +52,7 @@ the AUTHENTICATE command. For instance the following configuration
snippet saves bandwidth and brings a significant speed gain compared to
type=imaps.
- local: $XDG_CONFIG_HOME/interimap:
+ local: $XDG_CONFIG_HOME/interimap/config:
[remote]
type = tunnel
command = /usr/bin/ssh user@imap.example.net
@@ -82,6 +82,6 @@ usage with regular INET sockets (type=imaps or type=imap).
_______________________________________________________________________
-InterIMAP is Copyright© 2015 Guilhem Moulin ⟨guilhem@fripost.org⟩, and
-licensed for use under the GNU General Public License version 3 or
+InterIMAP is Copyright© 2015-2018 Guilhem Moulin ⟨guilhem@fripost.org⟩,
+and licensed for use under the GNU General Public License version 3 or
later. See ‘COPYING’ for specific terms and distribution information.
diff --git a/interimap b/interimap
index 049b564..454d311 100755
--- a/interimap
+++ b/interimap
@@ -2,7 +2,7 @@
#----------------------------------------------------------------------
# Fast bidirectional synchronization for QRESYNC-capable IMAP servers
-# Copyright © 2015,2016 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
@@ -18,19 +18,21 @@
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#----------------------------------------------------------------------
+use v5.14.2;
use strict;
use warnings;
-our $VERSION = '0.3';
+our $VERSION = '0.4';
my $NAME = 'interimap';
use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
bundling auto_version/;
use DBI ();
+use DBD::SQLite::Constants ':file_open';
use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC/;
use List::Util 'first';
use lib 'lib';
-use Net::IMAP::InterIMAP qw/read_config compact_set/;
+use Net::IMAP::InterIMAP 0.0.4 qw/xdg_basedir read_config compact_set/;
# Clean up PATH
$ENV{PATH} = join ':', qw{/usr/bin /bin};
@@ -63,20 +65,24 @@ my $COMMAND = do {
};
usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or ($COMMAND eq 'rename' and $#ARGV != 1));
usage(1) if defined $COMMAND and (defined $CONFIG{watch} or defined $CONFIG{notify});
-usage(1) if $CONFIG{target} and !(defined $COMMAND and ($COMMAND eq 'delete'or $COMMAND eq 'rename'));
+usage(1) if $CONFIG{target} and !(defined $COMMAND and ($COMMAND eq 'delete' or $COMMAND eq 'rename'));
$CONFIG{watch} = $CONFIG{notify} ? 900 : 60 if (defined $CONFIG{watch} or $CONFIG{notify}) and !$CONFIG{watch};
@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive
die "Invalid mailbox name $_" foreach grep !/\A([\x01-\x7F]+)\z/, @ARGV;
-my $CONF = read_config( delete $CONFIG{config} // $NAME
- , [qw/_ local remote/]
- , database => qr/\A(\P{Control}+)\z/
- , logfile => qr/\A(\/\P{Control}+)\z/
- , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
- , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/
- , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
- );
+my $CONF = do {
+ my $conffile = delete($CONFIG{config}) // "config";
+ $conffile = xdg_basedir( XDG_CONFIG_HOME => ".config", $NAME, $conffile );
+ read_config( $conffile
+ , [qw/_ local remote/]
+ , database => qr/\A(\P{Control}+)\z/
+ , logfile => qr/\A(\/\P{Control}+)\z/
+ , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
+ , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/
+ , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
+ );
+};
my ($DBFILE, $LOGGER_FD);
{
@@ -84,16 +90,7 @@ my ($DBFILE, $LOGGER_FD);
$DBFILE //= $CONF->{remote}->{host}.'.db' if defined $CONF->{remote};
$DBFILE //= $CONF->{local}->{host}. '.db' if defined $CONF->{local};
die "Missing option database" unless defined $DBFILE;
-
- unless ($DBFILE =~ /\A\//) {
- my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME;
- $dir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $dir";
- $dir = $1;
- $DBFILE = $dir .'/'. $DBFILE;
- unless (-d $dir) {
- mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n";
- }
- }
+ $DBFILE = xdg_basedir( XDG_DATA_HOME => ".local/share", $NAME, $DBFILE );
if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) {
require 'POSIX.pm';
@@ -125,18 +122,24 @@ $SIG{TERM} = sub { cleanup(); exit 0; };
#############################################################################
# Open the database and create tables
-$DBH = DBI::->connect("dbi:SQLite:dbname=$DBFILE", undef, undef, {
- AutoCommit => 0,
- RaiseError => 1,
- sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not
- sqlite_use_immediate_transaction => 1,
-});
-$DBH->sqlite_busy_timeout(250);
-$DBH->do('PRAGMA locking_mode = EXCLUSIVE');
-$DBH->do('PRAGMA foreign_keys = ON');
-
{
+ my $dbi_data_source = "dbi:SQLite:dbname=".$DBFILE;
+ my %dbi_attrs = (
+ AutoCommit => 0,
+ RaiseError => 1,
+ sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not
+ sqlite_use_immediate_transaction => 1,
+ sqlite_open_flags => SQLITE_OPEN_READWRITE
+ );
+ # don't auto-create in long-lived mode
+ $dbi_attrs{sqlite_open_flags} |= SQLITE_OPEN_CREATE unless defined $CONFIG{watch};
+
+ $DBH = DBI::->connect($dbi_data_source, undef, undef, \%dbi_attrs);
+ $DBH->sqlite_busy_timeout(250);
+ $DBH->do('PRAGMA locking_mode = EXCLUSIVE');
+ $DBH->do('PRAGMA foreign_keys = ON');
+
my @schema = (
mailboxes => [
q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
@@ -166,6 +169,10 @@ $DBH->do('PRAGMA foreign_keys = ON');
# also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT (except for interrupted syncs)
# mapping.idx must be found among local.idx (and remote.idx)
],
+
+ # We have no version number in the schema, but if we ever need a
+ # migration, we'll add a new table, and assume version 1.0 if
+ # the table is missing.
);
# Invariants:
diff --git a/interimap.md b/interimap.md
index 4a321f1..4d85eaf 100644
--- a/interimap.md
+++ b/interimap.md
@@ -140,8 +140,8 @@ Options
`--config=`*FILE*
: Specify an alternate [configuration file](#configuration-file).
- Relative paths start from *$XDG_CONFIG_HOME*, or *~/.config* if the
- `XDG_CONFIG_HOME` environment variable is unset.
+ Relative paths start from *$XDG_CONFIG_HOME/interimap*, or *~/.config/interimap*
+ if the `XDG_CONFIG_HOME` environment variable is unset.
`--target={local,remote,database}`
@@ -192,9 +192,9 @@ Configuration file
==================
Unless told otherwise by the `--config=FILE` command-line option,
-`interimap` reads its configuration from *$XDG_CONFIG_HOME/interimap*
-(or *~/.config/interimap* if the `XDG_CONFIG_HOME` environment variable
-is unset) as an [INI file].
+`interimap` reads its configuration from *$XDG_CONFIG_HOME/interimap/config*
+(or *~/.config/interimap/config* if the `XDG_CONFIG_HOME` environment
+variable is unset) as an [INI file].
The syntax of the configuration file is a series of `OPTION=VALUE`
lines organized under some `[SECTION]`; lines starting with a ‘#’ or
‘;’ character are ignored as comments.
@@ -332,9 +332,10 @@ Valid options are:
: A space-separated list of SSL protocols to enable or disable (if
prefixed with an exclamation mark `!`. Known protocols are `SSLv2`,
- `SSLv3`, `TLSv1`, `TLSv1.1`, and `TLSv1.2`. Enabling a protocol is
- a short-hand for disabling all other protocols.
- (Default: `!SSLv2 !SSLv3`, i.e., only enable TLSv1 and above.)
+ `SSLv3`, `TLSv1`, `TLSv1.1`, `TLSv1.2`, and `TLSv1.3`. Enabling a
+ protocol is a short-hand for disabling all other protocols.
+ (Default: `!SSLv2 !SSLv3 !TLSv1 !TLSv1.1`, i.e., only enable TLSv1.2
+ and above.)
*SSL_cipher_list*
@@ -398,7 +399,9 @@ Known bugs and limitations
* Using `interimap` on two identical servers with a non-existent or
empty *database* will duplicate each message due to the absence of
- local ↔ remote UID association.
+ local ↔ remote UID association. Hence one needs to manually empty
+ the mail store on one end when migrating to `interimap` from another
+ synchronisation solution.
* `interimap` is single threaded and doesn't use IMAP command
pipelining. Synchronization could be boosted up by sending
diff --git a/interimap.sample b/interimap.sample
index 8cd0a29..f771e54 100644
--- a/interimap.sample
+++ b/interimap.sample
@@ -1,4 +1,4 @@
-#database = imap.guilhem.org.db
+#database = imap.example.org.db
#list-mailbox = "*"
list-select-opts = SUBSCRIBED
ignore-mailbox = ^virtual/
diff --git a/interimap.service b/interimap.service
index 6e487d4..8e9915f 100644
--- a/interimap.service
+++ b/interimap.service
@@ -4,7 +4,7 @@ Wants=network-online.target
After=network-online.target
[Service]
-ExecStart=/usr/bin/interimap --notify
+ExecStart=/usr/bin/interimap --watch=60
RestartSec=10min
Restart=on-failure
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';
diff --git a/pullimap b/pullimap
index dca8c49..495b99e 100755
--- a/pullimap
+++ b/pullimap
@@ -2,7 +2,7 @@
#----------------------------------------------------------------------
# Pull mails from an IMAP mailbox and deliver them to a SMTP session
-# Copyright © 2016 Guilhem Moulin <guilhem@fripost.org>
+# Copyright © 2016-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
@@ -21,7 +21,8 @@
use strict;
use warnings;
-our $VERSION = '0.3';
+use v5.20.2;
+our $VERSION = '0.4';
my $NAME = 'pullimap';
use Errno 'EINTR';
@@ -31,7 +32,7 @@ use List::Util 'first';
use Socket qw/PF_INET PF_INET6 SOCK_STREAM/;
use lib 'lib';
-use Net::IMAP::InterIMAP qw/read_config compact_set/;
+use Net::IMAP::InterIMAP 0.0.4 qw/xdg_basedir read_config compact_set/;
# Clean up PATH
$ENV{PATH} = join ':', qw{/usr/bin /bin};
@@ -59,15 +60,19 @@ usage(1) unless $#ARGV == 0 and $ARGV[0] ne '_';
#######################################################################
# Read and validate configuration
#
-my $CONF = read_config( delete $CONFIG{config} // $NAME,
- , [$ARGV[0]]
- , statefile => qr/\A(\P{Control}+)\z/
- , mailbox => qr/\A([\x01-\x7F]+)\z/
- , 'deliver-method' => qr/\A([ls]mtp:\[.*\]:\d+)\z/
- , 'deliver-ehlo' => qr/\A(\P{Control}+)\z/
- , 'deliver-rcpt' => qr/\A(\P{Control}+)\z/
- , 'purge-after' => qr/\A(\d*)\z/
- )->{$ARGV[0]};
+my $CONF = do {
+ my $conffile = delete($CONFIG{config}) // "config";
+ $conffile = xdg_basedir( XDG_CONFIG_HOME => ".config", $NAME, $conffile );
+ read_config( $conffile
+ , [$ARGV[0]]
+ , statefile => qr/\A(\P{Control}+)\z/
+ , mailbox => qr/\A([\x01-\x7F]+)\z/
+ , 'deliver-method' => qr/\A([ls]mtp:\[.*\]:\d+)\z/
+ , 'deliver-ehlo' => qr/\A(\P{Control}+)\z/
+ , 'deliver-rcpt' => qr/\A(\P{Control}+)\z/
+ , 'purge-after' => qr/\A(\d*)\z/
+ )->{$ARGV[0]};
+};
my ($MAILBOX, $STATE);
do {
@@ -75,23 +80,23 @@ do {
my $statefile = $CONF->{statefile} // $ARGV[0];
die "Missing option statefile" unless defined $statefile;
- $statefile = $statefile =~ /\A(\p{Print}+)\z/ ? $1 : die "Insecure $statefile";
-
- unless ($statefile =~ /\A\//) {
- my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME;
- $dir = $dir =~ /\A(\/\p{Print}+)\z/ ? $1 : die "Insecure $dir";
- $statefile = $dir .'/'. $statefile;
- unless (-d $dir) {
- mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n";
- }
- }
+ $statefile = xdg_basedir( XDG_DATA_HOME => ".local/share", $NAME, $statefile );
+
+ my $mode = O_RDWR | O_DSYNC;
+ # don't auto-create in long-lived mode
+ $mode |= O_CREAT unless defined $CONFIG{idle};
- sysopen($STATE, $statefile, O_CREAT|O_RDWR|O_DSYNC, 0600) or die "Can't open $statefile: $!";
+ sysopen($STATE, $statefile, $mode, 0600) or die "Can't open $statefile: $!";
# XXX we need to pack the struct flock manually: not portable!
my $struct_flock = pack('s!s!l!l!i!', F_WRLCK, SEEK_SET, 0, 0, 0);
fcntl($STATE, F_SETLK, $struct_flock) or die "Can't lock $statefile: $!";
my $flags = fcntl($STATE, F_GETFD, 0) or die "fcntl F_GETFD: $!";
fcntl($STATE, F_SETFD, $flags | FD_CLOEXEC) or die "fcntl F_SETFD: $!";
+
+ # We have no version number in the statefile, but if we ever need a
+ # migration, we'll add a 1-byte header for the version number, and
+ # assume version 1.0 if the size of the file is a multiple of 4
+ # bytes. (We can also use the fact that bytes 5 to 8 are never all 0.)
};
@@ -249,10 +254,20 @@ sub purge() {
my @now = gmtime($now - $days*86400);
my @m = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; # RFC 3501's date-month
my $date = sprintf("%02d-%s-%04d", $now[3], $m[$now[4]], $now[5]+1900);
- my @uid = $IMAP->search("UID $set BEFORE $date");
-
- $set = @uid ? compact_set(@uid) : undef;
- $IMAP->log("Removing ".($#uid+1)." UID(s) $set") if defined $set and !$CONFIG{quiet};
+ my $ext = $IMAP->incapable('ESEARCH') ? undef : [qw/COUNT ALL/];
+ my @uid = $IMAP->search((defined $ext ? "RETURN (".join(' ', @$ext).') ' : '')
+ ."UID $set BEFORE $date");
+ my $count;
+ if (defined $ext) {
+ my ($uid_indicator, %resp) = @uid;
+ $IMAP->panic() unless defined $uid_indicator and $uid_indicator = 'UID';
+ $count = $resp{COUNT} // $IMAP->panic();
+ $set = $resp{ALL}; # MUST NOT be present if there are no matches
+ } else {
+ $count = $#uid+1;
+ $set = $count == 0 ? undef : compact_set(@uid);
+ }
+ $IMAP->log("Removing $count UID(s) $set") if $count > 0 and !$CONFIG{quiet};
}
if (defined $set) {
diff --git a/pullimap.md b/pullimap.md
index cb2a07a..a367dd1 100644
--- a/pullimap.md
+++ b/pullimap.md
@@ -32,8 +32,8 @@ Options
`--config=`*FILE*
: Specify an alternate [configuration file](#configuration-file).
- Relative paths start from *$XDG_CONFIG_HOME*, or *~/.config* if the
- `XDG_CONFIG_HOME` environment variable is unset.
+ Relative paths start from *$XDG_CONFIG_HOME/pullimap*, or *~/.config/pullimap*
+ if the `XDG_CONFIG_HOME` environment variable is unset.
`--idle`[`=`*seconds*]
@@ -74,9 +74,9 @@ Configuration file
==================
Unless told otherwise by the `--config=FILE` command-line option,
-`pullimap` reads its configuration from *$XDG_CONFIG_HOME/pullimap* (or
-*~/.config/pullimap* if the `XDG_CONFIG_HOME` environment variable is
-unset) as an [INI file].
+`pullimap` reads its configuration from *$XDG_CONFIG_HOME/pullimap/config*
+(or *~/.config/pullimap/config* if the `XDG_CONFIG_HOME` environment variable
+is unset) as an [INI file].
The syntax of the configuration file is a series of `OPTION=VALUE`
lines organized under some `[SECTION]`; lines starting with a ‘#’ or
‘;’ character are ignored as comments.
@@ -121,9 +121,10 @@ Valid options are:
the IMAP server. (The value is at best 24h accurate due to the IMAP
`SEARCH` criterion ignoring time and timezone.)
If *purge-after* is set to `0` then messages are deleted immediately
- after delivery. Otherwise `pullimap` issues an IMAP `SEARCH`
- command to list old messages; if `--idle` is set then the `SEARCH`
- command is issued again every 12 hours.
+ after delivery. Otherwise `pullimap` issues an IMAP `SEARCH` (or
+ extended `SEARCH` on servers advertizing the [`ESEARCH`][RFC 4731]
+ capability) command to list old messages; if `--idle` is set then
+ the `SEARCH` command is issued again every 12 hours.
*type*
@@ -197,9 +198,10 @@ Valid options are:
: A space-separated list of SSL protocols to enable or disable (if
prefixed with an exclamation mark `!`. Known protocols are `SSLv2`,
- `SSLv3`, `TLSv1`, `TLSv1.1`, and `TLSv1.2`. Enabling a protocol is
- a short-hand for disabling all other protocols.
- (Default: `!SSLv2 !SSLv3`, i.e., only enable TLSv1 and above.)
+ `SSLv3`, `TLSv1`, `TLSv1.1`, `TLSv1.2`, and `TLSv1.3`. Enabling a
+ protocol is a short-hand for disabling all other protocols.
+ (Default: `!SSLv2 !SSLv3 !TLSv1 !TLSv1.1`, i.e., only enable TLSv1.2
+ and above.)
*SSL_cipher_list*
@@ -339,6 +341,9 @@ Standards
[RFC 4315], December 2005.
* A. Gulbrandsen, _The IMAP `COMPRESS` Extension_,
[RFC 4978], August 2007.
+ * A. Melnikov and D. Cridland, _IMAP4 Extension to SEARCH Command for
+ Controlling What Kind of Information Is Returned_,
+ [RFC 4731], November 2006.
* R. Siemborski and A. Gulbrandsen, _IMAP Extension for Simple
Authentication and Security Layer (SASL) Initial Client Response_,
[RFC 4959], September 2007.
@@ -358,6 +363,7 @@ Standards
[RFC 4978]: https://tools.ietf.org/html/rfc4978
[RFC 1928]: https://tools.ietf.org/html/rfc1928
[RFC 1929]: https://tools.ietf.org/html/rfc1929
+[RFC 4731]: https://tools.ietf.org/html/rfc4731
[INI file]: https://en.wikipedia.org/wiki/INI_file
[`fetchmail`(1)]: http://www.fetchmail.info/
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 17:29:45 +0000