To avoid confusion with http://imapsync.lamiral.info .
-imapsync (0.1) upstream;
+interimap (0.1) upstream;
- * Initial release.
+ * Initial public release. Development was started in July 2015.
- -- Guilhem Moulin <guilhem@guilhem.org> Thu, 23 Jul 2015 04:15:47 +0200
+ -- Guilhem Moulin <guilhem@guilhem.org> Mon, 07 Sep 2015 17:14:42 +0200
-imapsync depends on the following Perl modules:
+InterIMAP depends on the following Perl modules:
- Config::Tiny
- DBI
-imapsync is a fast bidirectional synchronization program for
-QRESYNC-capable IMAP servers. Consult the manual for more information.
+InterIMAP is a fast two-way synchronization program for QRESYNC-capable
+IMAP4rev1 servers. Consult the manual for more information.
#######################################################################
messages, then 2/ copy the new messages. The naive way to perform the
first step is to issue a FETCH command to list all messages in the
mailbox along with their flags and UIDs, causing heavy network usage.
-Instead, imapsync takes advantage of the QRESYNC extension from
+Instead, InterIMAP takes advantage of the QRESYNC extension from
[RFC7162] to perform stateful synchronization: querying changes since
the last synchronization only gives a phenomenal performance boost and
drastically reduces the network traffic.
For convenience reasons servers must also support LIST-EXTENDED
[RFC5258], LIST-STATUS [RFC5819] and UIDPLUS [RFC4315]. Furthermore,
-while imapsync can work with servers lacking support for LITERAL+
+while InterIMAP can work with servers lacking support for LITERAL+
[RFC2088] and MULTIAPPEND [RFC3502], these extensions greatly improve
performance by reducing the number of required round trips hence are
recommended.
snippet saves bandwidth and brings a significant speed gain compared to
type=imaps.
- local: $XDG_CONFIG_HOME/imapsync:
+ local: $XDG_CONFIG_HOME/interimap:
[remote]
type = tunnel
command = /usr/bin/ssh user@imap.example.net
local: ~/.ssh/config:
Host imap.example.net
- IdentityFile ~/.ssh/id-imapsync
+ IdentityFile ~/.ssh/id-interimap
IdentitiesOnly yes
ControlPath /run/shm/%u@%n
ControlMaster auto
Compression yes
remote: ~user/.ssh/authorized_keys:
- command="/usr/lib/dovecot/imap",no-agent-forwarding,no-port-forwarding,no-pty,no-user-rc,no-X11-forwarding ssh-... id-imapsync
+ command="/usr/lib/dovecot/imap",no-agent-forwarding,no-port-forwarding,no-pty,no-user-rc,no-X11-forwarding ssh-... id-interimap
#######################################################################
-imapsync is Copyright© 2015 Guilhem Moulin ⟨guilhem@fripost.org⟩, and
+InterIMAP is Copyright© 2015 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.
+++ /dev/null
-#!/usr/bin/perl -T
-
-#----------------------------------------------------------------------
-# IMAP-to-IMAP synchronization program for QRESYNC-capable servers
-# Copyright © 2015 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
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>.
-#----------------------------------------------------------------------
-
-use strict;
-use warnings;
-
-our $VERSION = '0.1';
-my $NAME = 'imapsync';
-use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
- bundling auto_version/;
-use DBI ();
-use List::Util 'first';
-
-use lib 'lib';
-use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/;
-
-# Clean up PATH
-$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin};
-delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
-
-my %CONFIG;
-sub usage(;$) {
- my $rv = shift // 0;
- if ($rv) {
- print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n"
- ."Try '$NAME --help' or consult the manpage for more information.\n";
- }
- else {
- print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n"
- ." or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n"
- ." or: $NAME [OPTIONS] --delete MAILBOX [..]\n"
- ." or: $NAME [OPTIONS] --rename SOURCE DEST\n"
- ."Consult the manpage for more information.\n";
- }
- exit $rv;
-}
-usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h repair delete rename/);
-usage(0) if $CONFIG{help};
-my $COMMAND = do {
- my @command = grep {exists $CONFIG{$_}} qw/repair delete rename/;
- usage(1) if $#command>0;
- $command[0]
-};
-usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND eq 'rename' and $#ARGV != 1);
-@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive
-
-
-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 ($DBFILE, $LOCKFILE, $LOGGER_FD);
-
-{
- $DBFILE = $CONF->{_}->{database} if defined $CONF->{_};
- $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";
- }
- }
-
- $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r;
-
- if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) {
- require 'POSIX.pm';
- require 'Time/HiRes.pm';
- open $LOGGER_FD, '>>', $CONF->{_}->{logfile}
- or die "Can't open $CONF->{_}->{logfile}: $!\n";
- $LOGGER_FD->autoflush(1);
- }
- elsif ($CONFIG{debug}) {
- $LOGGER_FD = \*STDERR;
- }
-}
-my $DBH;
-
-# Clean after us
-sub cleanup() {
- logger(undef, "Cleaning up...") if $CONFIG{debug};
- unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
- close $LOGGER_FD if defined $LOGGER_FD;
- $DBH->disconnect() if defined $DBH;
-}
-$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 1; } foreach qw/INT TERM/;
-$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 0; } foreach qw/HUP/;
-
-
-#############################################################################
-# Lock the database
-{
- if (-f $LOCKFILE) {
- open my $lock, '<', $LOCKFILE or die "Can't open $LOCKFILE: $!\n";
- my $pid = <$lock>;
- close $lock;
- chomp $pid;
- my $msg = "LOCKFILE '$LOCKFILE' exists.";
- $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/;
- die $msg, "\n";
- }
-
- open my $lock, '>', $LOCKFILE or die "Can't open $LOCKFILE: $!\n";
- print $lock $$, "\n";
- close $lock;
-}
-
-
-#############################################################################
-# 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
-});
-$DBH->do('PRAGMA foreign_keys = ON');
-
-
-{
- my @schema = (
- mailboxes => [
- q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
- q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE},
- q{subscribed BOOLEAN NOT NULL}
- ],
- local => [
- q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
- q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
- q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially
- q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially
- # one-to-one correspondence between local.idx and remote.idx
- ],
- remote => [
- q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
- q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
- q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially
- q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially
- # one-to-one correspondence between local.idx and remote.idx
- ],
- mapping => [
- q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)},
- q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)},
- q{rUID UNSIGNED INT NOT NULL CHECK (rUID > 0)},
- q{PRIMARY KEY (idx,lUID)},
- q{UNIQUE (idx,rUID)}
- # also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT (except for interrupted syncs)
- # mapping.idx must be found among local.idx (and remote.idx)
- ],
- );
-
- # Invariants:
- # * UIDVALIDITY never changes.
- # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ <
- # {local,remote}.HIGHESTMODSEQ have been propagated.
- # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT
- # (resp. <= remote.UIDNEXT).
- # * Any idx in `local` must be present in `remote` and vice-versa.
- # * Any idx in `mapping` must be present in `local` and `remote`.
- while (@schema) {
- my $table = shift @schema;
- my $schema = shift @schema;
- my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1});
- my $row = $sth->fetch();
- die if defined $sth->fetch(); # sanity check
- unless (defined $row) {
- $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")");
- $DBH->commit();
- }
- }
-}
-
-sub msg($@) {
- my $name = shift;
- return unless @_;
- logger($name, @_) if defined $LOGGER_FD and $LOGGER_FD->fileno != fileno STDERR;
- my $prefix = defined $name ? "$name: " : '';
- print STDERR $prefix, @_, "\n";
-}
-sub logger($@) {
- my $name = shift;
- return unless @_ and defined $LOGGER_FD;
- my $prefix = '';
- if ($LOGGER_FD->fileno != fileno STDERR) {
- my ($s, $us) = Time::HiRes::gettimeofday();
- $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us ";
- }
- $prefix .= "$name: " if defined $name;
- $LOGGER_FD->say($prefix, @_);
-}
-logger(undef, ">>> $NAME $VERSION");
-
-
-#############################################################################
-# Connect to the local and remote IMAP servers
-
-my $IMAP;
-foreach my $name (qw/local remote/) {
- my %config = %{$CONF->{$name}};
- $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/;
- $config{enable} = 'QRESYNC';
- $config{name} = $name;
- $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
-
- $IMAP->{$name} = { client => Net::IMAP::Sync::->new(%config) };
- my $client = $IMAP->{$name}->{client};
-
- die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED LIST-STATUS UIDPLUS/);
- # XXX We should start by listing all mailboxes matching the user's LIST
- # criterion, then issue "SET NOTIFY (mailboxes ... (...))". But this
- # crashes the IMAP client:
- # http://dovecot.org/pipermail/dovecot/2015-July/101473.html
- #my $mailboxes = $client->list((uc $config{'subscribed-only'} eq 'TRUE' ? '(SUBSCRIBED)' : '' )
- # .$config{mailboxes}, 'SUBSCRIBED');
- # $client->notify('SELECTED', 'MAILBOXES ('.join(' ', keys %$mailboxes).')');
- # XXX NOTIFY doesn't work as expected for INBOX
- # http://dovecot.org/pipermail/dovecot/2015-July/101514.html
- #$client->notify(qw/SELECTED SUBSCRIBED/) if $CONFIG{watch};
- # XXX We shouldn't need to ask for STATUS responses here, and use
- # NOTIFY's STATUS indicator instead. However Dovecot violates RFC
- # 5464: http://dovecot.org/pipermail/dovecot/2015-July/101474.html
-
- my $list = '"" ';
- my @params;
- if (!defined $COMMAND or $COMMAND eq 'repair') {
- $list = '('.uc($CONF->{_}->{'list-select-opts'}).') '.$list if defined $CONF->{_}->{'list-select-opts'};
- $list .= (defined $CONF->{_}->{'list-mailbox'} ? '('.$CONF->{_}->{'list-mailbox'}.')' : '*') unless @ARGV;
- @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)');
- }
- $list .= $#ARGV == 0 ? Net::IMAP::Sync::quote($ARGV[0])
- : ('('.join(' ',map {Net::IMAP::Sync::quote($_)} @ARGV).')') if @ARGV;
- @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list($list, @params);
-}
-
-
-##############################################################################
-#
-
-# Add a new mailbox to the database.
-my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
-
-# Get the index associated with a mailbox.
-my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?});
-
-# Ensure local and remote delimiter match
-sub check_delim($) {
- my $mbx = shift;
- my ($lDelims, $rDelims) = map {$IMAP->{$_}->{delims}} qw/local remote/;
- if (exists $lDelims->{$mbx} and exists $rDelims->{$mbx} and
- ((defined $lDelims->{$mbx} xor defined $rDelims->{$mbx}) or
- (defined $lDelims->{$mbx} and defined $rDelims->{$mbx} and $lDelims->{$mbx} ne $rDelims->{$mbx}))) {
- my ($ld, $rd) = ($lDelims->{$mbx}, $rDelims->{$mbx});
- $ld =~ s/([\x22\x5C])/\\$1/g if defined $ld;
- $rd =~ s/([\x22\x5C])/\\$1/g if defined $rd;
- die "Error: Hierarchy delimiter for $mbx don't match: "
- ."local \"". ($ld // '')."\", remote \"".($rd // '')."\"\n"
- }
- return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef;
-}
-
-# Return true if $mailbox exists on $name
-sub mbx_exists($$) {
- my ($name, $mailbox) = @_;
- my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox};
- return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0;
-}
-
-# Return true if $mailbox is subscribed to on $name
-sub mbx_subscribed($$) {
- my ($name, $mailbox) = @_;
- my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox};
- return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0;
-}
-
-
-##############################################################################
-# Process --delete command
-#
-if (defined $COMMAND and $COMMAND eq 'delete') {
- my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?});
- my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?});
- my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?});
- my $sth_delete_mapping = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ?});
-
- foreach my $mailbox (@ARGV) {
- $STH_GET_INDEX->execute($mailbox);
- my ($idx) = $STH_GET_INDEX->fetchrow_array();
- die if defined $STH_GET_INDEX->fetch(); # sanity check
-
- # delete $mailbox on servers where $mailbox exists. note that
- # there is a race condition where the mailbox could have
- # appeared meanwhile
- foreach my $name (qw/local remote/) {
- next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}};
- $IMAP->{$name}->{client}->delete($mailbox) if mbx_exists($name, $mailbox);
- }
-
- if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) {
- my $r1 = $sth_delete_mapping->execute($idx);
- msg('database', "WARNING: `DELETE FROM mapping WHERE idx = $idx` failed") unless $r1;
- my $r2 = $sth_delete_local->execute($idx);
- msg('database', "WARNING: `DELETE FROM local WHERE idx = $idx` failed") unless $r2;
- my $r3 = $sth_delete_remote->execute($idx);
- msg('database', "WARNING: `DELETE FROM remote WHERE idx = $idx` failed") unless $r3;
- my $r4 = $sth_delete_mailboxes->execute($idx);
- msg('database', "WARNING: `DELETE FROM mailboxes WHERE idx = $idx` failed") unless $r4;
-
- $DBH->commit();
- msg('database', "Removed mailbox $mailbox") if $r4;
- }
- }
- exit 0;
-}
-
-
-##############################################################################
-# Process --rename command
-#
-elsif (defined $COMMAND and $COMMAND eq 'rename') {
- my ($from, $to) = @ARGV;
-
- # get index of the original name
- $STH_GET_INDEX->execute($from);
- my ($idx) = $STH_GET_INDEX->fetchrow_array();
- die if defined $STH_GET_INDEX->fetch(); # sanity check
-
- # ensure the local and remote hierarchy delimiter match
- my $delim = check_delim($from);
-
- # ensure the target name doesn't already exist on the servers. there
- # is a race condition where the mailbox would be created before we
- # issue the RENAME command, then the server would reply with a
- # tagged NO response
- foreach my $name (qw/local remote/) {
- next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}};
- if (mbx_exists($name, $to)) {
- msg($name, "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete.");
- exit 1;
- }
- }
-
- # ensure the target name doesn't already exist in the database
- $STH_GET_INDEX->execute($to);
- if (defined $STH_GET_INDEX->fetch() and
- (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) {
- msg('database', "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete.");
- exit 1;
- }
-
-
- # rename $from to $to on servers where $from exists. again there is
- # a race condition, but if $to has been created meanwhile the server
- # will reply with a tagged NO response
- foreach my $name (qw/local remote/) {
- next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}};
- $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from);
- }
-
- # rename from to $to in the database
- if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) {
- my $sth_rename_mailbox = $DBH->prepare(q{UPDATE mailboxes SET mailbox = ? WHERE idx = ?});
- my $r = $sth_rename_mailbox->execute($to, $idx);
- msg('database', "WARNING: `UPDATE mailboxes SET mailbox = ".$DBH->quote($to)." WHERE idx = $idx` failed") unless $r;
-
- # for non-flat mailboxes, rename the children as well
- if (defined $delim) {
- my $prefix = $from.$delim;
- my $sth_rename_children = $DBH->prepare(q{
- UPDATE mailboxes SET mailbox = ? || SUBSTR(mailbox,?)
- WHERE SUBSTR(mailbox,1,?) = ?
- });
- $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix);
- }
-
- $DBH->commit();
- msg('database', "Renamed mailbox $from to $to") if $r;
- }
- exit 0;
-}
-
-
-##############################################################################
-# Synchronize mailbox and subscription lists
-
-my @MAILBOXES;
-{
- my %mailboxes;
- $mailboxes{$_} = 1 foreach keys %{$IMAP->{local}->{mailboxes}};
- $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}};
- my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?});
-
- foreach my $mailbox (keys %mailboxes) {
- next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox =~ /$CONF->{_}->{'ignore-mailbox'}/o;
- my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/;
- next unless $lExists or $rExists;
-
- my @attrs = do {
- my %attrs = map {$_ => 1} (@{$IMAP->{local}->{mailboxes}->{$mailbox} // []},
- @{$IMAP->{remote}->{mailboxes}->{$mailbox} // []});
- keys %attrs;
- };
-
- check_delim($mailbox); # ensure that the delimiter match
- push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs;
-
- $STH_GET_INDEX->execute($mailbox);
- my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array();
- die if defined $STH_GET_INDEX->fetch(); # sanity check
-
- if ($lExists and $rExists) {
- # $mailbox exists on both sides
- my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/;
- if (defined $idx) {
- if ($lSubscribed xor $rSubscribed) {
- # mailbox is subscribed on only one server
- if ($subscribed) { # unsubscribe
- my $name = $lSubscribed ? 'local' : 'remote';
- $IMAP->{$name}->{client}->unsubscribe($mailbox);
- }
- else { # subscribe
- my $name = $lSubscribed ? 'remote' : 'local';
- $IMAP->{$name}->{client}->subscribe($mailbox);
- }
- # toggle subscribtion in the database
- $subscribed = $subscribed ? 0 : 1;
- $sth_subscribe->execute($subscribed, $idx) or
- msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $subscribed WHERE idx = $idx` failed");
- $DBH->commit();
- }
- # $mailbox is either subscribed on both servers, or subscribed on both
- elsif ($lSubscribed xor $subscribed) {
- # update the database if needed
- $sth_subscribe->execute($lSubscribed, $idx) or
- msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $lSubscribed WHERE idx = $idx` failed");
- $DBH->commit();
- }
- }
- else {
- # add new mailbox; subscribe on both servers if $mailbox is subscribed on one of them
- my $subscribed = ($lSubscribed or $rSubscribed) ? 1 : 0;
- $STH_INSERT_MAILBOX->execute($mailbox, $subscribed);
- $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed and !$lSubscribed;
- $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed and !$rSubscribed;
- $DBH->commit();
- }
- }
- elsif ($lExists and !$rExists) {
- # $mailbox is on 'local' only
- if (defined $idx) {
- msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete.");
- exit 1;
- }
- my $subscribed = mbx_subscribed('local', $mailbox);
- $STH_INSERT_MAILBOX->execute($mailbox, $subscribed);
- $IMAP->{remote}->{client}->create($mailbox, 1);
- $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed;
- $DBH->commit();
- }
- elsif (!$lExists and $rExists) {
- # $mailbox is on 'remote' only
- if (defined $idx) {
- msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete.");
- exit 1;
- }
- my $subscribed = mbx_subscribed('remote', $mailbox);
- $STH_INSERT_MAILBOX->execute($mailbox, $subscribed);
- $IMAP->{local}->{client}->create($mailbox, 1);
- $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed;
- $DBH->commit();
- }
- }
-}
-my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
-undef $IMAP;
-
-
-#############################################################################
-# Synchronize messages
-
-# Get all cached states from the database.
-my $STH_GET_CACHE = $DBH->prepare(q{
- SELECT mailbox, m.idx AS idx,
- l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ,
- r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ
- FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
-});
-my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{
- SELECT mailbox,
- l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ,
- r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ
- FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
- WHERE m.idx = ?
-});
-
-# Find local/remote UID from the map.
-my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?});
-my $STH_GET_REMOTE_UID = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? and lUID = ?});
-
-# Delete a (idx,lUID,rUID) association.
-# /!\ Don't commit before the messages have actually been EXPUNGEd on both sides!
-my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?});
-
-# Update the HIGHESTMODSEQ.
-my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?});
-my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?});
-
-# Update the HIGHESTMODSEQ and UIDNEXT.
-my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
-my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
-
-# Add a new mailbox.
-my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)});
-my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)});
-
-# Insert or retrieve a (idx,lUID,rUID) association.
-my $STH_INSERT_MAPPING = $DBH->prepare(q{INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)});
-my $STH_GET_MAPPING = $DBH->prepare(q{SELECT lUID,rUID FROM mapping WHERE idx = ?});
-
-# Get the list of interrupted mailbox syncs.
-my $STH_LIST_INTERRUPTED = $DBH->prepare(q{
- SELECT mbx.idx, mailbox
- FROM mailboxes mbx JOIN local l ON mbx.idx = l.idx JOIN remote r ON mbx.idx = r.idx JOIN mapping ON mbx.idx = mapping.idx
- WHERE (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT)
- GROUP BY mbx.idx
-});
-
-# For an interrupted mailbox sync, get the pairs (lUID,rUID) that have
-# already been downloaded.
-my $STH_GET_INTERRUPTED_BY_IDX = $DBH->prepare(q{
- SELECT lUID, rUID
- FROM mapping m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
- WHERE m.idx = ? AND (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT)
-});
-
-# Count messages
-my $STH_COUNT_MESSAGES = $DBH->prepare(q{SELECT COUNT(*) FROM mapping WHERE idx = ?});
-
-# List last 1024 messages UIDs
-my $STH_LASTUIDs_LOCAL = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? ORDER BY lUID DESC LIMIT 1024});
-my $STH_LASTUIDs_REMOTE = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? ORDER BY rUID DESC LIMIT 1024});
-
-
-# Download some missing UIDs from $source; returns the thew allocated UIDs
-sub download_missing($$$@) {
- my $idx = shift;
- my $mailbox = shift;
- my $source = shift;
- my @set = @_;
- my @uids;
-
- my $target = $source eq 'local' ? 'remote' : 'local';
-
- my ($buff, $bufflen) = ([], 0);
- undef $buff if ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND');
-
- my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/;
- ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) {
- my $mail = shift;
- return unless exists $mail->{RFC822}; # not for us
-
- my $uid = $mail->{UID};
- my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
- $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
- msg(undef, "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet};
-
- callback_new_message($idx, $mailbox, $source, $mail, \@uids, $buff, \$bufflen)
- });
- push @uids, callback_new_message_flush($idx, $mailbox, $source, @$buff) if defined $buff and @$buff;
- return @uids;
-}
-
-
-# Solve a flag update conflict (by taking the union of the two flag lists).
-sub flag_conflict($$$$$) {
- my ($mailbox, $lUID, $lFlags, $rUID, $rFlags) = @_;
-
- my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags));
- my $flags = join ' ', sort(keys %flags);
- msg(undef, "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ".
- "and remote UID $rUID ($rFlags). Setting both to the union ($flags).");
-
- return $flags
-}
-
-
-# Delete a mapping ($idx, $lUID)
-sub delete_mapping($$) {
- my ($idx, $lUID) = @_;
- my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
- die if $r > 1; # sanity check
- msg('database', "WARNING: Can't delete (idx,lUID) = ($idx,$lUID)") if $r == 0;
-}
-
-
-# Create a sample (sequence numbers, UIDs) to use as Message Sequence
-# Match Data for the QRESYNC parameter to the SELECT command.
-# QRESYNC [RFC7162] doesn't force the server to remember the MODSEQs of
-# EXPUNGEd messages. By passing a sample of known sequence numbers/UIDs
-# we let the server know that the messages have been EXPUNGEd [RFC7162,
-# section 3.2.5.2].
-# The UID set is the largest set of higest UIDs with at most 1024 UIDs,
-# of length (after compacting) at most 64.
-# The reason why we sample with the highest UIDs is that lowest UIDs are
-# less likely to be deleted.
-sub sample($$$) {
- my ($idx, $count, $sth) = @_;
- return unless $count > 0;
-
- my ($n, $uids, $min, $max);
- $sth->execute($idx);
- while (defined (my $row = $sth->fetchrow_arrayref())) {
- my $k = $row->[0];
- if (!defined $min and !defined $max) {
- $n = 0;
- $min = $max = $k;
- }
- elsif ($k == $min - 1) {
- $min--;
- }
- else {
- $n += $max - $min + 1;
- $uids = ($min == $max ? $min : "$min:$max")
- .(defined $uids ? ','.$uids : '');
- $min = $max = $k;
- if (length($uids) > 64) {
- $sth->finish(); # done with the statement
- last;
- }
- }
- }
- if (!defined $uids or length($uids) <= 64) {
- $n += $max - $min + 1;
- $uids = ($min == $max ? $min : "$min:$max")
- .(defined $uids ? ','.$uids : '');
- }
- return ( ($count - $n + 1).':'.$count, $uids );
-}
-
-
-# Issue a SELECT command with the given $mailbox.
-sub select_mbx($$) {
- my ($idx, $mailbox) = @_;
-
- $STH_COUNT_MESSAGES->execute($idx);
- my ($count) = $STH_COUNT_MESSAGES->fetchrow_array();
- die if defined $STH_COUNT_MESSAGES->fetch(); # sanity check
-
- $lIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_LOCAL));
- $rIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_REMOTE));
-}
-
-
-# Check and repair synchronization of a mailbox between the two servers
-# (in a very crude way, by downloading all existing UID with their flags)
-sub repair($) {
- my $mailbox = shift;
-
- $STH_GET_INDEX->execute($mailbox);
- my ($idx) = $STH_GET_INDEX->fetchrow_array();
- die if defined $STH_GET_INDEX->fetch(); # sanity check
-
- return unless defined $idx; # not in the database
- select_mbx($idx, $mailbox);
-
- $STH_GET_CACHE_BY_IDX->execute($idx);
- my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // return; # no cache
- die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check
-
- # get all existing UID with their flags
- my ($lVanished, $lModified) = $lIMAP->pull_updates(1);
- my ($rVanished, $rModified) = $rIMAP->pull_updates(1);
-
- my %lVanished = map {$_ => 1} @$lVanished;
- my %rVanished = map {$_ => 1} @$rVanished;
-
- my (@lToRemove, %lToUpdate, @lMissing);
- my (@rToRemove, %rToUpdate, @rMissing);
- my @delete_mapping;
-
- # process each pair ($lUID,$rUID) found in the mapping table, and
- # compare with the result from the IMAP servers to detect anomalies
-
- $STH_GET_MAPPING->execute($idx);
- while (defined (my $row = $STH_GET_MAPPING->fetch())) {
- my ($lUID, $rUID) = @$row;
- if (defined $lModified->{$lUID} and defined $rModified->{$rUID}) {
- # both $lUID and $rUID are known; see sync_known_messages
- # for the sync algorithm
- my ($lFlags, $rFlags) = ($lModified->{$lUID}->[1], $rModified->{$rUID}->[1]);
- if ($lFlags eq $rFlags) {
- # no conflict
- }
- elsif ($lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
- $rModified->{$rUID}->[0] > $cache->{rHIGHESTMODSEQ}) {
- # set $lUID to $rFlags
- $lToUpdate{$rFlags} //= [];
- push @{$lToUpdate{$rFlags}}, $lUID;
- }
- elsif ($lModified->{$lUID}->[0] > $cache->{lHIGHESTMODSEQ} and
- $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) {
- # set $rUID to $lFlags
- $rToUpdate{$lFlags} //= [];
- push @{$rToUpdate{$lFlags}}, $rUID;
- }
- else {
- # conflict
- msg(undef, "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.")
- if $lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
- $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ};
- # set both $lUID and $rUID to the union of $lFlags and $rFlags
- my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags);
- $lToUpdate{$flags} //= [];
- push @{$lToUpdate{$flags}}, $lUID;
- $rToUpdate{$flags} //= [];
- push @{$rToUpdate{$flags}}, $rUID;
- }
- }
- elsif (!defined $lModified->{$lUID} and !defined $rModified->{$rUID}) {
- unless ($lVanished{$lUID} and $rVanished{$rUID}) {
- msg(undef, "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing.");
- push @delete_mapping, $lUID;
- }
- }
- elsif (!defined $lModified->{$lUID}) {
- push @delete_mapping, $lUID;
- if ($lVanished{$lUID}) {
- push @rToRemove, $rUID;
- } else {
- msg("local($mailbox)", "WARNING: UID $lUID disappeared. Downloading remote UID $rUID again.");
- push @rMissing, $rUID;
- }
- }
- elsif (!defined $rModified->{$rUID}) {
- push @delete_mapping, $lUID;
- if ($rVanished{$rUID}) {
- push @lToRemove, $lUID;
- } else {
- msg("remote($mailbox)", "WARNING: UID $rUID disappeared. Downloading local UID $lUID again.");
- push @lMissing, $lUID;
- }
- }
-
- delete $lModified->{$lUID};
- delete $lVanished{$lUID};
- delete $rModified->{$rUID};
- delete $rVanished{$rUID};
- }
-
- # remove messages on the IMAP side; will increase HIGHESTMODSEQ
- $lIMAP->remove_message(@lToRemove) if @lToRemove;
- $rIMAP->remove_message(@rToRemove) if @rToRemove;
-
- # remove entries in the table
- delete_mapping($idx, $_) foreach @delete_mapping;
- $DBH->commit() if @delete_mapping;
-
- # push flag updates; will increase HIGHESTMODSEQ
- while (my ($lFlags,$lUIDs) = each %lToUpdate) {
- $lIMAP->push_flag_updates($lFlags, @$lUIDs);
- }
- while (my ($rFlags,$rUIDs) = each %rToUpdate) {
- $rIMAP->push_flag_updates($rFlags, @$rUIDs);
- }
-
-
- # Process UID found in IMAP but not in the mapping table.
- my @lDunno = keys %lVanished;
- my @rDunno = keys %rVanished;
- msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) "
- .compact_set(@lDunno).". Ignoring.") if @lDunno;
- msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) "
- .compact_set(@rDunno).". Ignoring.") if @rDunno;
-
- foreach my $lUID (keys %$lModified) {
- msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Downloading again.");
- push @lMissing, $lUID;
- }
- foreach my $rUID (keys %$rModified) {
- msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Downloading again.");
- push @rMissing, $rUID;
- }
-
- # download missing UIDs; will increase UIDNEXT and HIGHESTMODSEQ
- my @rIgnore = download_missing($idx, $mailbox, 'local', @lMissing) if @lMissing;
- my @lIgnore = download_missing($idx, $mailbox, 'remote', @rMissing) if @rMissing;
-
- # download new messages; this will also update UIDNEXT and HIGHESTMODSEQ in the database
- sync_messages($idx, $mailbox, \@lIgnore, \@rIgnore);
-}
-
-
-# Sync known messages. Since pull_updates is the last method call on
-# $lIMAP and $rIMAP, it is safe to call get_cache on either object after
-# this function, in order to update the HIGHESTMODSEQ.
-# Return true if an update was detected, and false otherwise
-sub sync_known_messages($$) {
- my ($idx, $mailbox) = @_;
- my $update = 0;
-
- # loop since processing might produce VANISHED or unsollicited FETCH responses
- while (1) {
- my ($lVanished, $lModified, $rVanished, $rModified);
-
- ($lVanished, $lModified) = $lIMAP->pull_updates();
- ($rVanished, $rModified) = $rIMAP->pull_updates();
-
- # repeat until we have nothing pending
- return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished;
- $update = 1;
-
- # process VANISHED messages
- # /!\ this might modify the VANISHED or MODIFIED cache!
- if (@$lVanished or @$rVanished) {
- my %lVanished = map {$_ => 1} @$lVanished;
- my %rVanished = map {$_ => 1} @$rVanished;
-
- # For each vanished UID, get the corresponding one on the
- # other side (from the DB); consider it as to be removed if
- # it hasn't been removed already.
-
- my (@lToRemove, @rToRemove, @lDunno, @rDunno);
- foreach my $lUID (@$lVanished) {
- $STH_GET_REMOTE_UID->execute($idx, $lUID);
- my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
- die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
- if (!defined $rUID) {
- push @lDunno, $lUID;
- }
- elsif (!exists $rVanished{$rUID}) {
- push @rToRemove, $rUID;
- }
- }
- foreach my $rUID (@$rVanished) {
- $STH_GET_LOCAL_UID->execute($idx, $rUID);
- my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
- die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
- if (!defined $lUID) {
- push @rDunno, $rUID;
- }
- elsif (!exists $lVanished{$lUID}) {
- push @lToRemove, $lUID;
- }
- }
-
- msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) "
- .compact_set(@lDunno).". Ignoring.") if @lDunno;
- msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) "
- .compact_set(@rDunno).". Ignoring.") if @rDunno;
-
- $lIMAP->remove_message(@lToRemove) if @lToRemove;
- $rIMAP->remove_message(@rToRemove) if @rToRemove;
-
- # remove existing mappings
- foreach my $lUID (@$lVanished, @lToRemove) {
- delete_mapping($idx, $lUID);
- }
- }
-
- # process FLAG updates
- # /!\ this might modify the VANISHED or MODIFIED cache!
- if (%$lModified or %$rModified) {
- my (%lToUpdate, %rToUpdate);
-
- # Take flags updates on both sides, and get the
- # corresponding UIDs on the other side (from the DB).
- # If it wasn't modified there, make it such; if it was
- # modified with the same flags list, ignore that message;
- # otherwise there is a conflict, and take the union.
- #
- # Group by flags in order to limit the number of round
- # trips.
-
- while (my ($lUID,$lFlags) = each %$lModified) {
- $STH_GET_REMOTE_UID->execute($idx, $lUID);
- my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
- die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
- if (!defined $rUID) {
- msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Try '--repair'.");
- }
- elsif (defined (my $rFlags = $rModified->{$rUID})) {
- unless ($lFlags eq $rFlags) {
- my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags);
- $lToUpdate{$flags} //= [];
- push @{$lToUpdate{$flags}}, $lUID;
- $rToUpdate{$flags} //= [];
- push @{$rToUpdate{$flags}}, $rUID;
- }
- }
- else {
- $rToUpdate{$lFlags} //= [];
- push @{$rToUpdate{$lFlags}}, $rUID;
- }
- }
- while (my ($rUID,$rFlags) = each %$rModified) {
- $STH_GET_LOCAL_UID->execute($idx, $rUID);
- my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
- die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
- if (!defined $lUID) {
- msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Try '--repair'.");
- }
- elsif (!exists $lModified->{$lUID}) {
- # conflicts are taken care of above
- $lToUpdate{$rFlags} //= [];
- push @{$lToUpdate{$rFlags}}, $lUID;
- }
- }
-
- while (my ($lFlags,$lUIDs) = each %lToUpdate) {
- $lIMAP->push_flag_updates($lFlags, @$lUIDs);
- }
- while (my ($rFlags,$rUIDs) = each %rToUpdate) {
- $rIMAP->push_flag_updates($rFlags, @$rUIDs);
- }
- }
- }
-}
-
-
-# The callback to use when FETCHing new messages from $name to add it to
-# the other one.
-# If defined, the array reference $UIDs will be fed with the newly added
-# UIDs.
-# If defined, $buff contains the list of messages to be appended with
-# MULTIAPPEND. In that case callback_new_message_flush should be called
-# after the FETCH.
-sub callback_new_message($$$$;$$$) {
- my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_;
- return unless exists $mail->{RFC822}; # not for us
-
- my $length = length $mail->{RFC822};
- if ($length == 0) {
- msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})");
- return;
- }
-
- my @UIDs;
- unless (defined $buff) {
- @UIDs = callback_new_message_flush($idx, $mailbox, $name, $mail);
- }
- else {
- # use MULTIAPPEND (RFC 3502)
- # proceed by batches of 1MB to save roundtrips without blowing up the memory
- if (@$buff and $$bufflen + $length > 1048576) {
- @UIDs = callback_new_message_flush($idx, $mailbox, $name, @$buff);
- @$buff = ();
- $$bufflen = 0;
- }
- push @$buff, $mail;
- $$bufflen += $length;
- }
- push @$UIDs, @UIDs if defined $UIDs;
-}
-
-
-# Add the given @messages (multiple messages are only allowed for
-# MULTIAPPEND-capable servers) from $name to the other server.
-# Returns the list of newly allocated UIDs.
-sub callback_new_message_flush($$$@) {
- my ($idx, $mailbox, $name, @messages) = @_;
-
- my $imap = $name eq 'local' ? $rIMAP : $lIMAP; # target client
- my @sUID = map {$_->{UID}} @messages;
- my @tUID = $imap->append($mailbox, @messages);
- die unless $#sUID == $#tUID; # sanity check
-
- my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID);
- for (my $k=0; $k<=$#messages; $k++) {
- logger(undef, "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox")
- if $CONFIG{debug};
- $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]);
- }
- $DBH->commit(); # commit only once per batch
-
- return @tUID;
-}
-
-
-# Sync both known and new messages
-# If the array references $lIgnore and $rIgnore are not empty, skip
-# the given UIDs.
-sub sync_messages($$;$$) {
- my ($idx, $mailbox, $lIgnore, $rIgnore) = @_;
-
- my %ignore = (local => ($lIgnore // []), remote => ($rIgnore // []));
- my $loop;
- do {
- # get new messages from $source (except @{$ignore{$source}}) and APPEND them to $target
- foreach my $source (qw/remote local/) { # pull remote mails first
- my $target = $source eq 'remote' ? 'local' : 'remote';
- my $buff = [] unless ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND');
- my $bufflen = 0;
- my @tUIDs;
-
- ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages(sub($) {
- callback_new_message($idx, $mailbox, $source, shift, \@tUIDs, $buff, \$bufflen)
- }, @{$ignore{$source}});
-
- push @tUIDs, callback_new_message_flush($idx, $mailbox, $source, @$buff)
- if defined $buff and @$buff;
- push @{$ignore{$target}}, @tUIDs;
-
- $loop = @tUIDs ? 1 : 0;
- }
- # since $source modifies $target's UIDNEXT upon new mails, we
- # need to check again the first $source (remote) whenever the
- # last one (local) added new messages to it
- }
- while ($loop);
-
- # both local and remote UIDNEXT are now up to date; proceed with
- # pending flag updates and vanished messages
- sync_known_messages($idx, $mailbox);
-
- # don't store the new UIDNEXTs before to avoid downloading these
- # mails again in the event of a crash
- $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $idx) or
- msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox");
- $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $idx) or
- msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox");
- $DBH->commit();
-}
-
-
-# Wait up to $timout seconds for notifications on either IMAP server.
-# Then issue a NOOP so the connection doesn't terminate for inactivity.
-sub wait_notifications(;$) {
- my $timeout = shift // 300;
-
- while ($timeout > 0) {
- my $r1 = $lIMAP->slurp();
- my $r2 = $rIMAP->slurp();
- last if $r1 or $r2; # got update!
-
- sleep 1;
- if (--$timeout == 0) {
- $lIMAP->noop();
- $rIMAP->noop();
- # might have got updates so exit the loop
- }
- }
-}
-
-
-#############################################################################
-# Resume interrupted mailbox syncs (before initializing the cache).
-#
-my ($MAILBOX, $IDX);
-$STH_LIST_INTERRUPTED->execute();
-while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) {
- next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailbox
- ($IDX, $MAILBOX) = @$row;
- msg(undef, "Resuming interrupted sync for $MAILBOX");
-
- my %lUIDs;
- $STH_GET_INTERRUPTED_BY_IDX->execute($IDX);
- while (defined (my $row = $STH_GET_INTERRUPTED_BY_IDX->fetchrow_arrayref())) {
- $lUIDs{$row->[0]} = $row->[1]; # pair ($lUID, $rUID)
- }
- die unless %lUIDs; # sanity check
-
- $lIMAP->select($MAILBOX);
- $rIMAP->select($MAILBOX);
-
- # FETCH all messages with their FLAGS to detect messages that have
- # vanished meanwhile, or for which there was a flag update.
-
- my (%lList, %rList); # The lists of existing local and remote UIDs
- my $attrs = '('.join(' ', qw/MODSEQ FLAGS/).')';
- $lIMAP->fetch(compact_set(keys %lUIDs), $attrs, sub($){ $lList{shift->{UID}} = 1 });
- $rIMAP->fetch(compact_set(values %lUIDs), $attrs, sub($){ $rList{shift->{UID}} = 1 });
-
- my (@lToRemove, @rToRemove);
- while (my ($lUID,$rUID) = each %lUIDs) {
- next if $lList{$lUID} and $rList{$rUID}; # exists on both
- push @lToRemove, $lUID if $lList{$lUID};
- push @rToRemove, $rUID if $rList{$rUID};
-
- delete_mapping($IDX, $lUID);
- }
-
- $lIMAP->remove_message(@lToRemove) if @lToRemove;
- $rIMAP->remove_message(@rToRemove) if @rToRemove;
- $DBH->commit() if @lToRemove or @rToRemove; # /!\ commit *after* remove_message!
-
- # ignore deleted messages
- delete @lList{@lToRemove};
- delete @rList{@rToRemove};
-
- # Resume the sync, but skip messages that have already been
- # downloaded. Flag updates will be processed automatically since
- # the _MODIFIED internal cache has been initialized with all our
- # UIDs. (Since there is no reliable HIGHESTMODSEQ, any flag
- # difference is treated as a conflict.)
- sync_messages($IDX, $MAILBOX, [keys %lList], [keys %rList]);
-}
-
-
-#############################################################################
-# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
-#
-my %KNOWN_INDEXES;
-$STH_GET_CACHE->execute();
-while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
- next unless grep {$row->{mailbox} eq $_} @MAILBOXES;
- $lIMAP->set_cache($row->{mailbox},
- UIDVALIDITY => $row->{lUIDVALIDITY},
- UIDNEXT => $row->{lUIDNEXT},
- HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ}
- );
- $rIMAP->set_cache($row->{mailbox},
- UIDVALIDITY => $row->{rUIDVALIDITY},
- UIDNEXT => $row->{rUIDNEXT},
- HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
- );
- $KNOWN_INDEXES{$row->{idx}} = 1;
-}
-
-if (defined $COMMAND and $COMMAND eq 'repair') {
- repair($_) foreach @MAILBOXES;
- exit 0;
-}
-
-
-while(1) {
- while(@MAILBOXES) {
- my $cache;
- my $update = 0;
- if (defined $MAILBOX and ($lIMAP->is_dirty($MAILBOX) or $rIMAP->is_dirty($MAILBOX))) {
- # $MAILBOX is dirty on either the local or remote mailbox
- sync_messages($IDX, $MAILBOX);
- }
- else {
- $MAILBOX = $lIMAP->next_dirty_mailbox(@MAILBOXES) // $rIMAP->next_dirty_mailbox(@MAILBOXES) // last;
- $MAILBOX = 'INBOX' if uc $MAILBOX eq 'INBOX'; # INBOX is case insensitive
-
- $STH_GET_INDEX->execute($MAILBOX);
- ($IDX) = $STH_GET_INDEX->fetchrow_array();
- die if defined $STH_GET_INDEX->fetch(); # sanity check
- die unless defined $IDX; # sanity check;
-
- select_mbx($IDX, $MAILBOX);
-
- if (!$KNOWN_INDEXES{$IDX}) {
- $STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX));
- $STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX));
-
- # no need to commit before the first mapping (lUID,rUID)
- $KNOWN_INDEXES{$IDX} = 1;
- }
- elsif (sync_known_messages($IDX, $MAILBOX)) {
- # sync updates to known messages before fetching new messages
- # get_cache is safe after pull_update
- $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or
- msg('database', "WARNING: Can't update local HIGHESTMODSEQ for $MAILBOX");
- $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or
- msg('database', "WARNING: Can't update remote HIGHESTMODSEQ for $MAILBOX");
- $DBH->commit();
- }
- sync_messages($IDX, $MAILBOX);
- }
- }
- # clean state!
- exit 0 unless defined $COMMAND and $COMMAND eq 'watch';
- wait_notifications(900);
-}
-
-END {
- $_->logout() foreach grep defined, ($lIMAP, $rIMAP);
- cleanup();
-}
+++ /dev/null
-.TH IMAPSYNC "1" "JULY 2015" "imapsync" "User Commands"
-
-.SH NAME
-imapsync \- IMAP-to-IMAP synchronization program for QRESYNC-capable servers
-
-.SH SYNOPSIS
-.B imapsync\fR [\fIOPTION\fR ...] [\fICOMMAND\fR] [\fIMAILBOX\fR ...]
-
-
-.SH DESCRIPTION
-.PP
-.B imapsync\fR performs stateful synchronization between two IMAP4rev1
-servers.
-Such synchronization is made possible by the QRESYNC extension from
-[RFC7162]; for convenience reasons servers must also support
-LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315].
-Furthermore, while \fBimapsync\fR can work with servers lacking support
-for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions
-greatly improve performance by reducing the number of required round
-trips hence are recommended.
-
-.PP
-Stateful synchronization is only possible for mailboxes supporting
-persistent message Unique Identifiers (UID) and persistent storage of
-mod\-sequences (MODSEQ); any non\-compliant mailbox will cause
-\fBimapsync\fR to abort.
-Furthermore, because UIDs are allocated not by the client but by the
-server, \fBimapsync\fR needs to keep track of associations between local
-and remote UIDs for each mailbox.
-The synchronization state of a mailbox consists of its UIDNEXT and
-HIGHESTMODSEQ values on each server;
-it is then assumed that each message with UID < $UIDNEXT have been
-replicated to the other server, and that the metadata (such as flags) of
-each message with MODSEQ <= $HIGHESTMODSEQ have been synchronized.
-Conceptually, the synchronization algorithm is derived from [RFC4549]
-with the [RFC7162, section 6] amendments, and works as follows:
-
-.nr step 1 1
-.IP \n[step]. 8
-SELECT (on both servers) a mailbox the current UIDNEXT or HIGHESTMODSEQ
-values of which differ from the values found in the database (for either
-server). Use the QRESYNC SELECT parameter from [RFC7162] to list
-changes (vanished messages and flag updates) since $HIGHESTMODSEQ to
-messages with UID<$UIDNEXT.
-
-.IP \n+[step].
-Propagate these changes onto the other server: get the corresponding
-UIDs from the database, then a/ issue an UID STORE + UID EXPUNGE command
-to remove messages that have not already been deleted on both servers,
-and b/ issue UID STORE commands to propagate flag updates (send a single
-command for each flag list in order the reduce the number of round
-trips).
-(Conflicts may occur if the metadata of a message has been updated on
-both servers with different flag lists; in that case \fBimapsync\fR
-issues a warning and updates the message on each server with the union
-of both flag lists.)
-Repeat this step if the server sent some updates in the meantime.
-Otherwise, update the HIGHESTMODSEQ value in the database.
-
-.IP \n+[step].
-Process new messages (if the current UIDNEXT value differ from the one
-found in the database) by issuing an UID FETCH command and for each
-message RFC822 body received, issue an APPEND command to the other
-server on\-the\-fly.
-Repeat this step if the server received new messages in the meantime.
-Otherwise, update the UIDNEXT value in the database.
-Go back to step 2 if the server sent some updates in the meantime.
-
-.IP \n+[step].
-Go back to step 1 to proceed with the next unsynchronized mailbox.
-
-.SH COMMANDS
-.PP
-By default \fBimapsync\fR synchronizes each mailbox listed by the
-\(lqLIST "" "*"\(rq IMAP command;
-the \fIlist-mailbox\fR, \fIlist-select-opts\fR and \fIignore-mailbox\fR
-options from the configuration file can be used to shrink that list and
-save bandwidth.
-However if some extra argument are provided on the command line,
-\fBimapsync\fR ignores said options and synchronizes the given
-\fIMAILBOX\fRes instead. Note that each \fIMAILBOX\fR is taken \(lqas
-is\(rq; in particular, it must be UTF-7 encoded, unquoted, and the list
-wildcards \(oq*\(cq and \(oq%\(cq are not interpolated.
-
-.PP
-If the synchronization was interrupted during a previous run while some
-messages were being replicated (but before the UIDNEXT or HIGHESTMODSEQ
-values have been updated), \fBimapsync\fR performs a \(lqfull
-synchronization\(rq on theses messages only:
-downloading the whole UID and flag lists on each servers allows
-\fBimapsync\fR to detect messages that have been removed or for which
-their flags have changed in the meantime.
-Finally, after propagating the offline changes for these messages,
-\fBimapsync\fR resumes the synchronization for the rest of the mailbox.
-
-.PP
-Specifying one of the commands below makes \fBimapsync\fR perform an
-action other than the default QRESYNC-based synchronization.
-
-.TP
-.B \-\-repair \fR[\fIMAILBOX\fR ...]
-List the database anomalies and try to repair them.
-(Consider only the given \fIMAILBOX\fRes if non-optional arguments are
-provided.)
-This is done by performing a so\-called \(lqfull synchronization\(rq,
-namely 1/ download all UIDs along with their flags from both the local
-and remote servers, 2/ ensure that each entry in the database corresponds
-to an existing UID, and 3/ ensure that both flag lists match.
-Any message found on a server but not in the database is replicated on
-the other server (which in the worst case, might lead to a message
-duplicate).
-Flag conflicts are solved by updating each message to the union of both
-lists.
-
-.TP
-.B \-\-delete \fIMAILBOX\fR [...]
-Delete the given \fIMAILBOX\fRes on each target (by default each server
-plus the database, unless \fB\-\-target\fR specifies otherwise) where
-it exists.
-Note that per [RFC3501] deletion is not recursive: \fIMAILBOX\fR's
-children are not deleted.
-
-.TP
-.B \-\-rename \fISOURCE\fR \fIDEST\fR
-Rename the mailbox \fISOURCE\fR to \fIDEST\fR on each target (by default
-each server plus the database, unless \fB\-\-target\fR specifies
-otherwise) where it exists.
-\fBimapsync\fR aborts if \fIDEST\fR already exists on either target.
-Note that per [RFC3501] the renaming is recursive: \fISOURCE\fR's
-children are moved to become \fIDEST\fR's children instead.
-
-
-.SH OPTIONS
-.TP
-.B \-\-config=\fR\fIFILE\fR
-Specify an alternate configuration file. Relative paths start from
-\fI$XDG_CONFIG_HOME\fR, or \fI~/.config\fR if the XDG_CONFIG_HOME
-environment variable is unset.
-
-.TP
-.B \fB\-\-target=\fR{local,remote,database}
-Limit the scope of a \fB\-\-delete\fR or \fB\-\-rename\fR command
-to the given target. Can be repeated to act on multiple targets. By
-default all three targets are considered.
-
-.TP
-.B \-q\fR, \fB\-\-quiet\fR
-Try to be quiet.
-
-.TP
-.B \-\-debug
-Turn on debug mode. Debug messages are written to the given \fIlogfile\fR.
-Note that this include all IMAP traffic (except literals). Depending on the
-chosen authentication mechanism, this might include authentication credentials.
-
-.TP
-.B \-h\fR, \fB\-\-help\fR
-Output a brief help and exit.
-
-.TP
-.B \-\-version
-Show the version number and exit.
-
-.SH CONFIGURATION FILE
-
-Unless told otherwise by the \fB\-\-config=\fR\fIFILE\fR option,
-\fBimapsync\fR reads its configuration from
-\fI$XDG_CONFIG_HOME/imapsync\fR (or \fI~/.config/imapsync\fR if the
-XDG_CONFIG_HOME environment variable is unset) as an INI file.
-The syntax of the configuration file is a serie of
-\fIOPTION\fR=\fIVALUE\fR lines organized under some \fI[SECTION]\fR;
-lines starting with a \(oq#\(cq or \(oq;\(cq character are ignored as
-comments.
-The sections \(lq[local]\(rq and \(lq[remote]\(rq define the two IMAP
-servers to synchronize.
-Valid options are:
-
-.TP
-.I database
-SQLite version 3 database file to use to keep track of associations
-between local and remote UIDs, as well as the UIDVALIDITY, UIDNEXT and
-HIGHESTMODSEQ of each known mailbox on both servers.
-Relative paths start from \fI$XDG_DATA_HOME/imapsync\fR, or
-\fI~/.local/share/imapsync\fR if the XDG_DATA_HOME environment variable
-is unset.
-This option is only available in the default section.
-(Default: \(lq\fIhost\fR.db\)\(rq, where \fIhost\fR is taken from the
-\(lq[remote]\(rq or \(lq[local]\(rq sections, in that order.)
-
-.TP
-.I list-mailbox
-A space separated list of mailbox patterns to use when issuing the
-initial LIST command (overridden by the \fIMAILBOX\fRes given as
-command-line arguments).
-Note that each pattern containing special characters such as spaces or
-brackets (see [RFC3501] for the exact syntax) must be quoted.
-Furthermore, non-ASCII names must be UTF\-7 encoded.
-Two wildcards are available: a \(oq*\(cq character matches zero or more
-characters, while a \(oq%\(cq character matches zero or more characters
-up to the mailbox's hierarchy delimiter.
-This option is only available in the default section.
-(The default pattern, \(lq*\(rq, matches all visible mailboxes on the
-server.)
-
-.TP
-.I list-select-opts
-An optional space separated list of selectors for the initial LIST
-command. (Requires a server supporting the LIST-EXTENDED [RFC5258]
-extension.) Useful values are
-\(lqSUBSCRIBED\(rq (to list only subscribed mailboxes),
-\(lqREMOTE\(rq (to also list remote mailboxes on a server supporting
-mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes
-with children matching one of the \fIlist-mailbox\fR patterns above).
-This option is only available in the default section.
-
-.TP
-.I ignore-mailbox
-An optional Perl Compatible Regular Expressions (PCRE) covering
-mailboxes to exclude:
-any (UTF-7 encoded, unquoted) mailbox listed in the initial LIST
-responses is ignored if it matches the given expression.
-Note that the \fIMAILBOX\fRes given as command-line arguments bypass the
-check and are always considered for synchronization.
-This option is only available in the default section.
-
-.TP
-.I logfile
-A file name to use to log debug and informational messages. This option is
-only available in the default section.
-
-.TP
-.I type
-One of \(lqimap\(rq, \(lqimaps\(rq or \(lqtunnel\(rq.
-\fItype\fR=imap and \fItype\fR=imaps are respectively used for IMAP and
-IMAP over SSL/TLS connections over a INET socket.
-\fItype\fR=tunnel causes \fBimapsync\fR to open a pipe to a
-\fIcommand\fR instead of a raw socket.
-Note that specifying \fItype\fR=tunnel in the \(lq[remote]\(rq section
-makes the default \fIdatabase\fR to be \(lqlocalhost.db\(rq.
-(Default: \(lqimaps\(rq.)
-
-.TP
-.I host
-Server hostname, for \fItype\fR=imap and \fItype\fR=imaps.
-(Default: \(lqlocalhost\(rq.)
-
-.TP
-.I port
-Server port.
-(Default: \(lq143\(rq for \fItype\fR=imap, \(lq993\(rq for
-\fItype\fR=imaps.)
-
-.TP
-.I command
-Command to use for \fItype\fR=tunnel. Must speak the IMAP4rev1 protocol
-on its standard output, and understand it on its standard input.
-
-.TP
-.I STARTTLS
-Whether to use the \(lqSTARTTLS\(rq directive to upgrade to a secure
-connection. Setting this to \(lqYES\(rq for a server not advertising
-the \(lqSTARTTLS\(rq capability causes \fBimapsync\fR to immediately
-abort the connection.
-(Ignored for \fItype\fRs other than \(lqimap\(rq. Default: \(lqYES\(rq.)
-
-.TP
-.I auth
-Space\-separated list of preferred authentication mechanisms.
-\fBimapsync\fR uses the first mechanism in that list that is also
-advertised (prefixed with \(lqAUTH=\(rq) in the server's capability list.
-Supported authentication mechanisms are \(lqPLAIN\(rq and \(lqLOGIN\(rq.
-(Default: \(lqPLAIN LOGIN\(rq.)
-
-.TP
-.I username\fR, \fIpassword\fR
-Username and password to authenticate with. Can be required for non
-pre\-authenticated connections, depending on the chosen authentication
-mechanism.
-
-.TP
-.I SSL_cipher_list
-Cipher list to use for the connection.
-See \fIciphers\fR(1ssl) for the format of such list.
-
-.TP
-.I SSL_fingerprint
-Fingerprint of the server certificate in the form
-\fIALGO\fR$\fIDIGEST_HEX\fR, where \fIALGO\fR is the used algorithm
-(default \(lqsha256\(rq).
-Attempting to connect to a server with a non-matching certificate
-fingerprint causes \fBimapsync\fR to abort the connection immediately
-after the SSL/TLS handshake.
-
-.TP
-.I SSL_verify_trusted_peer
-Whether to verify that the peer certificate has been signed by a trusted
-Certificate Authority. Note that using \fISSL_fingerprint\fR to specify
-the fingerprint of the server certificate is orthogonal and does not
-rely on Certificate Authorities.
-(Default: \(lqYES\(rq.)
-
-.TP
-.I SSL_ca_path
-Directory containing the certificate(s) of the trusted Certificate
-Authorities, used for server certificate verification.
-
-.SH KNOWN BUGS AND LIMITATIONS
-
-.IP \[bu]
-Using \fBimapsync\fR on two identical servers with a non-existent or
-empty database will duplicate each message due to the absence of
-local/remote UID association.
-.IP \[bu]
-\fBimapsync\fR is single threaded and doesn't use IMAP command
-pipelining. Synchronization could be boosted up by sending independent
-commands (such as the initial LIST/STATUS command) to each server in
-parallel, and for a given server, by sending independent commands (such
-as flag updates) in a pipeline.
-.IP \[bu]
-Because the IMAP protocol doesn't have a specific response code for when
-a message is moved to another mailbox (using the MOVE command from
-[RFC6851] or COPY + STORE + EXPUNGE), moving a messages causes
-\fBimapsync\fR to believe that it was deleted while another one (which
-is replicated again) was added to the other mailbox in the meantime.
-
-.IP \[bu]
-\(lqPLAIN\(rq and \(lqLOGIN\(rq are the only authentication mechanisms
-currently supported.
-
-.SH AUTHOR
-Written by Guilhem Moulin
-.MT guilhem@fripost.org
-.ME .
+++ /dev/null
-# database = imap.guilhem.org.db
-#list-mailbox = "*"
-list-select-opts = SUBSCRIBED
-ignore-mailbox = ^virtual/
-
-[local]
-type = tunnel
-command = /usr/lib/dovecot/imap
-
-[remote]
-# type = imaps
-host = imap.guilhem.org
-# port = 993
-username = guilhem
-password = xxxxxxxxxxxxxxxx
-
-# SSL options
-#SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
-#SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605
-#SSL_verify_trusted_peer = YES
-SSL_ca_path = /etc/ssl/certs
-
-# vim:ft=dosini
+++ /dev/null
-[Unit]
-Description=IMAP-to-IMAP Syncronization service
-Wants=network-online.target
-After=network-online.target
-
-[Service]
-ExecStart=/usr/bin/imapsync
-RestartSec=60s
-Restart=always
-
-[Install]
-WantedBy=default.target
--- /dev/null
+#!/usr/bin/perl -T
+
+#----------------------------------------------------------------------
+# Fast two-way synchronization program for QRESYNC-capable IMAP servers
+# Copyright © 2015 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
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#----------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+our $VERSION = '0.1';
+my $NAME = 'interimap';
+use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
+ bundling auto_version/;
+use DBI ();
+use List::Util 'first';
+
+use lib 'lib';
+use Net::IMAP::InterIMAP qw/read_config compact_set $IMAP_text $IMAP_cond/;
+
+# Clean up PATH
+$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin};
+delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
+
+my %CONFIG;
+sub usage(;$) {
+ my $rv = shift // 0;
+ if ($rv) {
+ print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n"
+ ."Try '$NAME --help' or consult the manpage for more information.\n";
+ }
+ else {
+ print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n"
+ ." or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n"
+ ." or: $NAME [OPTIONS] --delete MAILBOX [..]\n"
+ ." or: $NAME [OPTIONS] --rename SOURCE DEST\n"
+ ."Consult the manpage for more information.\n";
+ }
+ exit $rv;
+}
+usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h repair delete rename/);
+usage(0) if $CONFIG{help};
+my $COMMAND = do {
+ my @command = grep {exists $CONFIG{$_}} qw/repair delete rename/;
+ usage(1) if $#command>0;
+ $command[0]
+};
+usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND eq 'rename' and $#ARGV != 1);
+@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive
+
+
+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 ($DBFILE, $LOCKFILE, $LOGGER_FD);
+
+{
+ $DBFILE = $CONF->{_}->{database} if defined $CONF->{_};
+ $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";
+ }
+ }
+
+ $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r;
+
+ if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) {
+ require 'POSIX.pm';
+ require 'Time/HiRes.pm';
+ open $LOGGER_FD, '>>', $CONF->{_}->{logfile}
+ or die "Can't open $CONF->{_}->{logfile}: $!\n";
+ $LOGGER_FD->autoflush(1);
+ }
+ elsif ($CONFIG{debug}) {
+ $LOGGER_FD = \*STDERR;
+ }
+}
+my $DBH;
+
+# Clean after us
+sub cleanup() {
+ logger(undef, "Cleaning up...") if $CONFIG{debug};
+ unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
+ close $LOGGER_FD if defined $LOGGER_FD;
+ $DBH->disconnect() if defined $DBH;
+}
+$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 1; } foreach qw/INT TERM/;
+$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 0; } foreach qw/HUP/;
+
+
+#############################################################################
+# Lock the database
+{
+ if (-f $LOCKFILE) {
+ open my $lock, '<', $LOCKFILE or die "Can't open $LOCKFILE: $!\n";
+ my $pid = <$lock>;
+ close $lock;
+ chomp $pid;
+ my $msg = "LOCKFILE '$LOCKFILE' exists.";
+ $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/;
+ die $msg, "\n";
+ }
+
+ open my $lock, '>', $LOCKFILE or die "Can't open $LOCKFILE: $!\n";
+ print $lock $$, "\n";
+ close $lock;
+}
+
+
+#############################################################################
+# 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
+});
+$DBH->do('PRAGMA foreign_keys = ON');
+
+
+{
+ my @schema = (
+ mailboxes => [
+ q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
+ q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE},
+ q{subscribed BOOLEAN NOT NULL}
+ ],
+ local => [
+ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
+ q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
+ q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially
+ q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially
+ # one-to-one correspondence between local.idx and remote.idx
+ ],
+ remote => [
+ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
+ q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
+ q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially
+ q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially
+ # one-to-one correspondence between local.idx and remote.idx
+ ],
+ mapping => [
+ q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)},
+ q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)},
+ q{rUID UNSIGNED INT NOT NULL CHECK (rUID > 0)},
+ q{PRIMARY KEY (idx,lUID)},
+ q{UNIQUE (idx,rUID)}
+ # also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT (except for interrupted syncs)
+ # mapping.idx must be found among local.idx (and remote.idx)
+ ],
+ );
+
+ # Invariants:
+ # * UIDVALIDITY never changes.
+ # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ <
+ # {local,remote}.HIGHESTMODSEQ have been propagated.
+ # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT
+ # (resp. <= remote.UIDNEXT).
+ # * Any idx in `local` must be present in `remote` and vice-versa.
+ # * Any idx in `mapping` must be present in `local` and `remote`.
+ while (@schema) {
+ my $table = shift @schema;
+ my $schema = shift @schema;
+ my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1});
+ my $row = $sth->fetch();
+ die if defined $sth->fetch(); # sanity check
+ unless (defined $row) {
+ $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")");
+ $DBH->commit();
+ }
+ }
+}
+
+sub msg($@) {
+ my $name = shift;
+ return unless @_;
+ logger($name, @_) if defined $LOGGER_FD and $LOGGER_FD->fileno != fileno STDERR;
+ my $prefix = defined $name ? "$name: " : '';
+ print STDERR $prefix, @_, "\n";
+}
+sub logger($@) {
+ my $name = shift;
+ return unless @_ and defined $LOGGER_FD;
+ my $prefix = '';
+ if ($LOGGER_FD->fileno != fileno STDERR) {
+ my ($s, $us) = Time::HiRes::gettimeofday();
+ $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us ";
+ }
+ $prefix .= "$name: " if defined $name;
+ $LOGGER_FD->say($prefix, @_);
+}
+logger(undef, ">>> $NAME $VERSION");
+
+
+#############################################################################
+# Connect to the local and remote IMAP servers
+
+my $IMAP;
+foreach my $name (qw/local remote/) {
+ my %config = %{$CONF->{$name}};
+ $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/;
+ $config{enable} = 'QRESYNC';
+ $config{name} = $name;
+ $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
+
+ $IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) };
+ my $client = $IMAP->{$name}->{client};
+
+ die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED LIST-STATUS UIDPLUS/);
+ # XXX We should start by listing all mailboxes matching the user's LIST
+ # criterion, then issue "SET NOTIFY (mailboxes ... (...))". But this
+ # crashes the IMAP client:
+ # http://dovecot.org/pipermail/dovecot/2015-July/101473.html
+ #my $mailboxes = $client->list((uc $config{'subscribed-only'} eq 'TRUE' ? '(SUBSCRIBED)' : '' )
+ # .$config{mailboxes}, 'SUBSCRIBED');
+ # $client->notify('SELECTED', 'MAILBOXES ('.join(' ', keys %$mailboxes).')');
+ # XXX NOTIFY doesn't work as expected for INBOX
+ # http://dovecot.org/pipermail/dovecot/2015-July/101514.html
+ #$client->notify(qw/SELECTED SUBSCRIBED/) if $CONFIG{watch};
+ # XXX We shouldn't need to ask for STATUS responses here, and use
+ # NOTIFY's STATUS indicator instead. However Dovecot violates RFC
+ # 5464: http://dovecot.org/pipermail/dovecot/2015-July/101474.html
+
+ my $list = '"" ';
+ my @params;
+ if (!defined $COMMAND or $COMMAND eq 'repair') {
+ $list = '('.uc($CONF->{_}->{'list-select-opts'}).') '.$list if defined $CONF->{_}->{'list-select-opts'};
+ $list .= (defined $CONF->{_}->{'list-mailbox'} ? '('.$CONF->{_}->{'list-mailbox'}.')' : '*') unless @ARGV;
+ @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)');
+ }
+ $list .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0])
+ : ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV;
+ @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list($list, @params);
+}
+
+
+##############################################################################
+#
+
+# Add a new mailbox to the database.
+my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
+
+# Get the index associated with a mailbox.
+my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?});
+
+# Ensure local and remote delimiter match
+sub check_delim($) {
+ my $mbx = shift;
+ my ($lDelims, $rDelims) = map {$IMAP->{$_}->{delims}} qw/local remote/;
+ if (exists $lDelims->{$mbx} and exists $rDelims->{$mbx} and
+ ((defined $lDelims->{$mbx} xor defined $rDelims->{$mbx}) or
+ (defined $lDelims->{$mbx} and defined $rDelims->{$mbx} and $lDelims->{$mbx} ne $rDelims->{$mbx}))) {
+ my ($ld, $rd) = ($lDelims->{$mbx}, $rDelims->{$mbx});
+ $ld =~ s/([\x22\x5C])/\\$1/g if defined $ld;
+ $rd =~ s/([\x22\x5C])/\\$1/g if defined $rd;
+ die "Error: Hierarchy delimiter for $mbx don't match: "
+ ."local \"". ($ld // '')."\", remote \"".($rd // '')."\"\n"
+ }
+ return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef;
+}
+
+# Return true if $mailbox exists on $name
+sub mbx_exists($$) {
+ my ($name, $mailbox) = @_;
+ my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox};
+ return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0;
+}
+
+# Return true if $mailbox is subscribed to on $name
+sub mbx_subscribed($$) {
+ my ($name, $mailbox) = @_;
+ my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox};
+ return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0;
+}
+
+
+##############################################################################
+# Process --delete command
+#
+if (defined $COMMAND and $COMMAND eq 'delete') {
+ my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?});
+ my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?});
+ my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?});
+ my $sth_delete_mapping = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ?});
+
+ foreach my $mailbox (@ARGV) {
+ $STH_GET_INDEX->execute($mailbox);
+ my ($idx) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+
+ # delete $mailbox on servers where $mailbox exists. note that
+ # there is a race condition where the mailbox could have
+ # appeared meanwhile
+ foreach my $name (qw/local remote/) {
+ next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}};
+ $IMAP->{$name}->{client}->delete($mailbox) if mbx_exists($name, $mailbox);
+ }
+
+ if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) {
+ my $r1 = $sth_delete_mapping->execute($idx);
+ msg('database', "WARNING: `DELETE FROM mapping WHERE idx = $idx` failed") unless $r1;
+ my $r2 = $sth_delete_local->execute($idx);
+ msg('database', "WARNING: `DELETE FROM local WHERE idx = $idx` failed") unless $r2;
+ my $r3 = $sth_delete_remote->execute($idx);
+ msg('database', "WARNING: `DELETE FROM remote WHERE idx = $idx` failed") unless $r3;
+ my $r4 = $sth_delete_mailboxes->execute($idx);
+ msg('database', "WARNING: `DELETE FROM mailboxes WHERE idx = $idx` failed") unless $r4;
+
+ $DBH->commit();
+ msg('database', "Removed mailbox $mailbox") if $r4;
+ }
+ }
+ exit 0;
+}
+
+
+##############################################################################
+# Process --rename command
+#
+elsif (defined $COMMAND and $COMMAND eq 'rename') {
+ my ($from, $to) = @ARGV;
+
+ # get index of the original name
+ $STH_GET_INDEX->execute($from);
+ my ($idx) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+
+ # ensure the local and remote hierarchy delimiter match
+ my $delim = check_delim($from);
+
+ # ensure the target name doesn't already exist on the servers. there
+ # is a race condition where the mailbox would be created before we
+ # issue the RENAME command, then the server would reply with a
+ # tagged NO response
+ foreach my $name (qw/local remote/) {
+ next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}};
+ if (mbx_exists($name, $to)) {
+ msg($name, "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete.");
+ exit 1;
+ }
+ }
+
+ # ensure the target name doesn't already exist in the database
+ $STH_GET_INDEX->execute($to);
+ if (defined $STH_GET_INDEX->fetch() and
+ (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) {
+ msg('database', "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete.");
+ exit 1;
+ }
+
+
+ # rename $from to $to on servers where $from exists. again there is
+ # a race condition, but if $to has been created meanwhile the server
+ # will reply with a tagged NO response
+ foreach my $name (qw/local remote/) {
+ next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}};
+ $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from);
+ }
+
+ # rename from to $to in the database
+ if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) {
+ my $sth_rename_mailbox = $DBH->prepare(q{UPDATE mailboxes SET mailbox = ? WHERE idx = ?});
+ my $r = $sth_rename_mailbox->execute($to, $idx);
+ msg('database', "WARNING: `UPDATE mailboxes SET mailbox = ".$DBH->quote($to)." WHERE idx = $idx` failed") unless $r;
+
+ # for non-flat mailboxes, rename the children as well
+ if (defined $delim) {
+ my $prefix = $from.$delim;
+ my $sth_rename_children = $DBH->prepare(q{
+ UPDATE mailboxes SET mailbox = ? || SUBSTR(mailbox,?)
+ WHERE SUBSTR(mailbox,1,?) = ?
+ });
+ $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix);
+ }
+
+ $DBH->commit();
+ msg('database', "Renamed mailbox $from to $to") if $r;
+ }
+ exit 0;
+}
+
+
+##############################################################################
+# Synchronize mailbox and subscription lists
+
+my @MAILBOXES;
+{
+ my %mailboxes;
+ $mailboxes{$_} = 1 foreach keys %{$IMAP->{local}->{mailboxes}};
+ $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}};
+ my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?});
+
+ foreach my $mailbox (keys %mailboxes) {
+ next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox =~ /$CONF->{_}->{'ignore-mailbox'}/o;
+ my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/;
+ next unless $lExists or $rExists;
+
+ my @attrs = do {
+ my %attrs = map {$_ => 1} (@{$IMAP->{local}->{mailboxes}->{$mailbox} // []},
+ @{$IMAP->{remote}->{mailboxes}->{$mailbox} // []});
+ keys %attrs;
+ };
+
+ check_delim($mailbox); # ensure that the delimiter match
+ push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs;
+
+ $STH_GET_INDEX->execute($mailbox);
+ my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+
+ if ($lExists and $rExists) {
+ # $mailbox exists on both sides
+ my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/;
+ if (defined $idx) {
+ if ($lSubscribed xor $rSubscribed) {
+ # mailbox is subscribed on only one server
+ if ($subscribed) { # unsubscribe
+ my $name = $lSubscribed ? 'local' : 'remote';
+ $IMAP->{$name}->{client}->unsubscribe($mailbox);
+ }
+ else { # subscribe
+ my $name = $lSubscribed ? 'remote' : 'local';
+ $IMAP->{$name}->{client}->subscribe($mailbox);
+ }
+ # toggle subscribtion in the database
+ $subscribed = $subscribed ? 0 : 1;
+ $sth_subscribe->execute($subscribed, $idx) or
+ msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $subscribed WHERE idx = $idx` failed");
+ $DBH->commit();
+ }
+ # $mailbox is either subscribed on both servers, or subscribed on both
+ elsif ($lSubscribed xor $subscribed) {
+ # update the database if needed
+ $sth_subscribe->execute($lSubscribed, $idx) or
+ msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $lSubscribed WHERE idx = $idx` failed");
+ $DBH->commit();
+ }
+ }
+ else {
+ # add new mailbox; subscribe on both servers if $mailbox is subscribed on one of them
+ my $subscribed = ($lSubscribed or $rSubscribed) ? 1 : 0;
+ $STH_INSERT_MAILBOX->execute($mailbox, $subscribed);
+ $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed and !$lSubscribed;
+ $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed and !$rSubscribed;
+ $DBH->commit();
+ }
+ }
+ elsif ($lExists and !$rExists) {
+ # $mailbox is on 'local' only
+ if (defined $idx) {
+ msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete.");
+ exit 1;
+ }
+ my $subscribed = mbx_subscribed('local', $mailbox);
+ $STH_INSERT_MAILBOX->execute($mailbox, $subscribed);
+ $IMAP->{remote}->{client}->create($mailbox, 1);
+ $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed;
+ $DBH->commit();
+ }
+ elsif (!$lExists and $rExists) {
+ # $mailbox is on 'remote' only
+ if (defined $idx) {
+ msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete.");
+ exit 1;
+ }
+ my $subscribed = mbx_subscribed('remote', $mailbox);
+ $STH_INSERT_MAILBOX->execute($mailbox, $subscribed);
+ $IMAP->{local}->{client}->create($mailbox, 1);
+ $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed;
+ $DBH->commit();
+ }
+ }
+}
+my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
+undef $IMAP;
+
+
+#############################################################################
+# Synchronize messages
+
+# Get all cached states from the database.
+my $STH_GET_CACHE = $DBH->prepare(q{
+ SELECT mailbox, m.idx AS idx,
+ l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ,
+ r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ
+ FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
+});
+my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{
+ SELECT mailbox,
+ l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ,
+ r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ
+ FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
+ WHERE m.idx = ?
+});
+
+# Find local/remote UID from the map.
+my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?});
+my $STH_GET_REMOTE_UID = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? and lUID = ?});
+
+# Delete a (idx,lUID,rUID) association.
+# /!\ Don't commit before the messages have actually been EXPUNGEd on both sides!
+my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?});
+
+# Update the HIGHESTMODSEQ.
+my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?});
+my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?});
+
+# Update the HIGHESTMODSEQ and UIDNEXT.
+my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
+my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
+
+# Add a new mailbox.
+my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)});
+my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)});
+
+# Insert or retrieve a (idx,lUID,rUID) association.
+my $STH_INSERT_MAPPING = $DBH->prepare(q{INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)});
+my $STH_GET_MAPPING = $DBH->prepare(q{SELECT lUID,rUID FROM mapping WHERE idx = ?});
+
+# Get the list of interrupted mailbox syncs.
+my $STH_LIST_INTERRUPTED = $DBH->prepare(q{
+ SELECT mbx.idx, mailbox
+ FROM mailboxes mbx JOIN local l ON mbx.idx = l.idx JOIN remote r ON mbx.idx = r.idx JOIN mapping ON mbx.idx = mapping.idx
+ WHERE (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT)
+ GROUP BY mbx.idx
+});
+
+# For an interrupted mailbox sync, get the pairs (lUID,rUID) that have
+# already been downloaded.
+my $STH_GET_INTERRUPTED_BY_IDX = $DBH->prepare(q{
+ SELECT lUID, rUID
+ FROM mapping m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
+ WHERE m.idx = ? AND (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT)
+});
+
+# Count messages
+my $STH_COUNT_MESSAGES = $DBH->prepare(q{SELECT COUNT(*) FROM mapping WHERE idx = ?});
+
+# List last 1024 messages UIDs
+my $STH_LASTUIDs_LOCAL = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? ORDER BY lUID DESC LIMIT 1024});
+my $STH_LASTUIDs_REMOTE = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? ORDER BY rUID DESC LIMIT 1024});
+
+
+# Download some missing UIDs from $source; returns the thew allocated UIDs
+sub download_missing($$$@) {
+ my $idx = shift;
+ my $mailbox = shift;
+ my $source = shift;
+ my @set = @_;
+ my @uids;
+
+ my $target = $source eq 'local' ? 'remote' : 'local';
+
+ my ($buff, $bufflen) = ([], 0);
+ undef $buff if ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND');
+
+ my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/;
+ ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) {
+ my $mail = shift;
+ return unless exists $mail->{RFC822}; # not for us
+
+ my $uid = $mail->{UID};
+ my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
+ $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
+ msg(undef, "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet};
+
+ callback_new_message($idx, $mailbox, $source, $mail, \@uids, $buff, \$bufflen)
+ });
+ push @uids, callback_new_message_flush($idx, $mailbox, $source, @$buff) if defined $buff and @$buff;
+ return @uids;
+}
+
+
+# Solve a flag update conflict (by taking the union of the two flag lists).
+sub flag_conflict($$$$$) {
+ my ($mailbox, $lUID, $lFlags, $rUID, $rFlags) = @_;
+
+ my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags));
+ my $flags = join ' ', sort(keys %flags);
+ msg(undef, "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ".
+ "and remote UID $rUID ($rFlags). Setting both to the union ($flags).");
+
+ return $flags
+}
+
+
+# Delete a mapping ($idx, $lUID)
+sub delete_mapping($$) {
+ my ($idx, $lUID) = @_;
+ my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
+ die if $r > 1; # sanity check
+ msg('database', "WARNING: Can't delete (idx,lUID) = ($idx,$lUID)") if $r == 0;
+}
+
+
+# Create a sample (sequence numbers, UIDs) to use as Message Sequence
+# Match Data for the QRESYNC parameter to the SELECT command.
+# QRESYNC [RFC7162] doesn't force the server to remember the MODSEQs of
+# EXPUNGEd messages. By passing a sample of known sequence numbers/UIDs
+# we let the server know that the messages have been EXPUNGEd [RFC7162,
+# section 3.2.5.2].
+# The UID set is the largest set of higest UIDs with at most 1024 UIDs,
+# of length (after compacting) at most 64.
+# The reason why we sample with the highest UIDs is that lowest UIDs are
+# less likely to be deleted.
+sub sample($$$) {
+ my ($idx, $count, $sth) = @_;
+ return unless $count > 0;
+
+ my ($n, $uids, $min, $max);
+ $sth->execute($idx);
+ while (defined (my $row = $sth->fetchrow_arrayref())) {
+ my $k = $row->[0];
+ if (!defined $min and !defined $max) {
+ $n = 0;
+ $min = $max = $k;
+ }
+ elsif ($k == $min - 1) {
+ $min--;
+ }
+ else {
+ $n += $max - $min + 1;
+ $uids = ($min == $max ? $min : "$min:$max")
+ .(defined $uids ? ','.$uids : '');
+ $min = $max = $k;
+ if (length($uids) > 64) {
+ $sth->finish(); # done with the statement
+ last;
+ }
+ }
+ }
+ if (!defined $uids or length($uids) <= 64) {
+ $n += $max - $min + 1;
+ $uids = ($min == $max ? $min : "$min:$max")
+ .(defined $uids ? ','.$uids : '');
+ }
+ return ( ($count - $n + 1).':'.$count, $uids );
+}
+
+
+# Issue a SELECT command with the given $mailbox.
+sub select_mbx($$) {
+ my ($idx, $mailbox) = @_;
+
+ $STH_COUNT_MESSAGES->execute($idx);
+ my ($count) = $STH_COUNT_MESSAGES->fetchrow_array();
+ die if defined $STH_COUNT_MESSAGES->fetch(); # sanity check
+
+ $lIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_LOCAL));
+ $rIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_REMOTE));
+}
+
+
+# Check and repair synchronization of a mailbox between the two servers
+# (in a very crude way, by downloading all existing UID with their flags)
+sub repair($) {
+ my $mailbox = shift;
+
+ $STH_GET_INDEX->execute($mailbox);
+ my ($idx) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+
+ return unless defined $idx; # not in the database
+ select_mbx($idx, $mailbox);
+
+ $STH_GET_CACHE_BY_IDX->execute($idx);
+ my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // return; # no cache
+ die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check
+
+ # get all existing UID with their flags
+ my ($lVanished, $lModified) = $lIMAP->pull_updates(1);
+ my ($rVanished, $rModified) = $rIMAP->pull_updates(1);
+
+ my %lVanished = map {$_ => 1} @$lVanished;
+ my %rVanished = map {$_ => 1} @$rVanished;
+
+ my (@lToRemove, %lToUpdate, @lMissing);
+ my (@rToRemove, %rToUpdate, @rMissing);
+ my @delete_mapping;
+
+ # process each pair ($lUID,$rUID) found in the mapping table, and
+ # compare with the result from the IMAP servers to detect anomalies
+
+ $STH_GET_MAPPING->execute($idx);
+ while (defined (my $row = $STH_GET_MAPPING->fetch())) {
+ my ($lUID, $rUID) = @$row;
+ if (defined $lModified->{$lUID} and defined $rModified->{$rUID}) {
+ # both $lUID and $rUID are known; see sync_known_messages
+ # for the sync algorithm
+ my ($lFlags, $rFlags) = ($lModified->{$lUID}->[1], $rModified->{$rUID}->[1]);
+ if ($lFlags eq $rFlags) {
+ # no conflict
+ }
+ elsif ($lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
+ $rModified->{$rUID}->[0] > $cache->{rHIGHESTMODSEQ}) {
+ # set $lUID to $rFlags
+ $lToUpdate{$rFlags} //= [];
+ push @{$lToUpdate{$rFlags}}, $lUID;
+ }
+ elsif ($lModified->{$lUID}->[0] > $cache->{lHIGHESTMODSEQ} and
+ $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) {
+ # set $rUID to $lFlags
+ $rToUpdate{$lFlags} //= [];
+ push @{$rToUpdate{$lFlags}}, $rUID;
+ }
+ else {
+ # conflict
+ msg(undef, "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.")
+ if $lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
+ $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ};
+ # set both $lUID and $rUID to the union of $lFlags and $rFlags
+ my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags);
+ $lToUpdate{$flags} //= [];
+ push @{$lToUpdate{$flags}}, $lUID;
+ $rToUpdate{$flags} //= [];
+ push @{$rToUpdate{$flags}}, $rUID;
+ }
+ }
+ elsif (!defined $lModified->{$lUID} and !defined $rModified->{$rUID}) {
+ unless ($lVanished{$lUID} and $rVanished{$rUID}) {
+ msg(undef, "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing.");
+ push @delete_mapping, $lUID;
+ }
+ }
+ elsif (!defined $lModified->{$lUID}) {
+ push @delete_mapping, $lUID;
+ if ($lVanished{$lUID}) {
+ push @rToRemove, $rUID;
+ } else {
+ msg("local($mailbox)", "WARNING: UID $lUID disappeared. Downloading remote UID $rUID again.");
+ push @rMissing, $rUID;
+ }
+ }
+ elsif (!defined $rModified->{$rUID}) {
+ push @delete_mapping, $lUID;
+ if ($rVanished{$rUID}) {
+ push @lToRemove, $lUID;
+ } else {
+ msg("remote($mailbox)", "WARNING: UID $rUID disappeared. Downloading local UID $lUID again.");
+ push @lMissing, $lUID;
+ }
+ }
+
+ delete $lModified->{$lUID};
+ delete $lVanished{$lUID};
+ delete $rModified->{$rUID};
+ delete $rVanished{$rUID};
+ }
+
+ # remove messages on the IMAP side; will increase HIGHESTMODSEQ
+ $lIMAP->remove_message(@lToRemove) if @lToRemove;
+ $rIMAP->remove_message(@rToRemove) if @rToRemove;
+
+ # remove entries in the table
+ delete_mapping($idx, $_) foreach @delete_mapping;
+ $DBH->commit() if @delete_mapping;
+
+ # push flag updates; will increase HIGHESTMODSEQ
+ while (my ($lFlags,$lUIDs) = each %lToUpdate) {
+ $lIMAP->push_flag_updates($lFlags, @$lUIDs);
+ }
+ while (my ($rFlags,$rUIDs) = each %rToUpdate) {
+ $rIMAP->push_flag_updates($rFlags, @$rUIDs);
+ }
+
+
+ # Process UID found in IMAP but not in the mapping table.
+ my @lDunno = keys %lVanished;
+ my @rDunno = keys %rVanished;
+ msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) "
+ .compact_set(@lDunno).". Ignoring.") if @lDunno;
+ msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) "
+ .compact_set(@rDunno).". Ignoring.") if @rDunno;
+
+ foreach my $lUID (keys %$lModified) {
+ msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Downloading again.");
+ push @lMissing, $lUID;
+ }
+ foreach my $rUID (keys %$rModified) {
+ msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Downloading again.");
+ push @rMissing, $rUID;
+ }
+
+ # download missing UIDs; will increase UIDNEXT and HIGHESTMODSEQ
+ my @rIgnore = download_missing($idx, $mailbox, 'local', @lMissing) if @lMissing;
+ my @lIgnore = download_missing($idx, $mailbox, 'remote', @rMissing) if @rMissing;
+
+ # download new messages; this will also update UIDNEXT and HIGHESTMODSEQ in the database
+ sync_messages($idx, $mailbox, \@lIgnore, \@rIgnore);
+}
+
+
+# Sync known messages. Since pull_updates is the last method call on
+# $lIMAP and $rIMAP, it is safe to call get_cache on either object after
+# this function, in order to update the HIGHESTMODSEQ.
+# Return true if an update was detected, and false otherwise
+sub sync_known_messages($$) {
+ my ($idx, $mailbox) = @_;
+ my $update = 0;
+
+ # loop since processing might produce VANISHED or unsollicited FETCH responses
+ while (1) {
+ my ($lVanished, $lModified, $rVanished, $rModified);
+
+ ($lVanished, $lModified) = $lIMAP->pull_updates();
+ ($rVanished, $rModified) = $rIMAP->pull_updates();
+
+ # repeat until we have nothing pending
+ return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished;
+ $update = 1;
+
+ # process VANISHED messages
+ # /!\ this might modify the VANISHED or MODIFIED cache!
+ if (@$lVanished or @$rVanished) {
+ my %lVanished = map {$_ => 1} @$lVanished;
+ my %rVanished = map {$_ => 1} @$rVanished;
+
+ # For each vanished UID, get the corresponding one on the
+ # other side (from the DB); consider it as to be removed if
+ # it hasn't been removed already.
+
+ my (@lToRemove, @rToRemove, @lDunno, @rDunno);
+ foreach my $lUID (@$lVanished) {
+ $STH_GET_REMOTE_UID->execute($idx, $lUID);
+ my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
+ die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $rUID) {
+ push @lDunno, $lUID;
+ }
+ elsif (!exists $rVanished{$rUID}) {
+ push @rToRemove, $rUID;
+ }
+ }
+ foreach my $rUID (@$rVanished) {
+ $STH_GET_LOCAL_UID->execute($idx, $rUID);
+ my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
+ die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $lUID) {
+ push @rDunno, $rUID;
+ }
+ elsif (!exists $lVanished{$lUID}) {
+ push @lToRemove, $lUID;
+ }
+ }
+
+ msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) "
+ .compact_set(@lDunno).". Ignoring.") if @lDunno;
+ msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) "
+ .compact_set(@rDunno).". Ignoring.") if @rDunno;
+
+ $lIMAP->remove_message(@lToRemove) if @lToRemove;
+ $rIMAP->remove_message(@rToRemove) if @rToRemove;
+
+ # remove existing mappings
+ foreach my $lUID (@$lVanished, @lToRemove) {
+ delete_mapping($idx, $lUID);
+ }
+ }
+
+ # process FLAG updates
+ # /!\ this might modify the VANISHED or MODIFIED cache!
+ if (%$lModified or %$rModified) {
+ my (%lToUpdate, %rToUpdate);
+
+ # Take flags updates on both sides, and get the
+ # corresponding UIDs on the other side (from the DB).
+ # If it wasn't modified there, make it such; if it was
+ # modified with the same flags list, ignore that message;
+ # otherwise there is a conflict, and take the union.
+ #
+ # Group by flags in order to limit the number of round
+ # trips.
+
+ while (my ($lUID,$lFlags) = each %$lModified) {
+ $STH_GET_REMOTE_UID->execute($idx, $lUID);
+ my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
+ die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $rUID) {
+ msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Try '--repair'.");
+ }
+ elsif (defined (my $rFlags = $rModified->{$rUID})) {
+ unless ($lFlags eq $rFlags) {
+ my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags);
+ $lToUpdate{$flags} //= [];
+ push @{$lToUpdate{$flags}}, $lUID;
+ $rToUpdate{$flags} //= [];
+ push @{$rToUpdate{$flags}}, $rUID;
+ }
+ }
+ else {
+ $rToUpdate{$lFlags} //= [];
+ push @{$rToUpdate{$lFlags}}, $rUID;
+ }
+ }
+ while (my ($rUID,$rFlags) = each %$rModified) {
+ $STH_GET_LOCAL_UID->execute($idx, $rUID);
+ my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
+ die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $lUID) {
+ msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Try '--repair'.");
+ }
+ elsif (!exists $lModified->{$lUID}) {
+ # conflicts are taken care of above
+ $lToUpdate{$rFlags} //= [];
+ push @{$lToUpdate{$rFlags}}, $lUID;
+ }
+ }
+
+ while (my ($lFlags,$lUIDs) = each %lToUpdate) {
+ $lIMAP->push_flag_updates($lFlags, @$lUIDs);
+ }
+ while (my ($rFlags,$rUIDs) = each %rToUpdate) {
+ $rIMAP->push_flag_updates($rFlags, @$rUIDs);
+ }
+ }
+ }
+}
+
+
+# The callback to use when FETCHing new messages from $name to add it to
+# the other one.
+# If defined, the array reference $UIDs will be fed with the newly added
+# UIDs.
+# If defined, $buff contains the list of messages to be appended with
+# MULTIAPPEND. In that case callback_new_message_flush should be called
+# after the FETCH.
+sub callback_new_message($$$$;$$$) {
+ my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_;
+ return unless exists $mail->{RFC822}; # not for us
+
+ my $length = length $mail->{RFC822};
+ if ($length == 0) {
+ msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})");
+ return;
+ }
+
+ my @UIDs;
+ unless (defined $buff) {
+ @UIDs = callback_new_message_flush($idx, $mailbox, $name, $mail);
+ }
+ else {
+ # use MULTIAPPEND (RFC 3502)
+ # proceed by batches of 1MB to save roundtrips without blowing up the memory
+ if (@$buff and $$bufflen + $length > 1048576) {
+ @UIDs = callback_new_message_flush($idx, $mailbox, $name, @$buff);
+ @$buff = ();
+ $$bufflen = 0;
+ }
+ push @$buff, $mail;
+ $$bufflen += $length;
+ }
+ push @$UIDs, @UIDs if defined $UIDs;
+}
+
+
+# Add the given @messages (multiple messages are only allowed for
+# MULTIAPPEND-capable servers) from $name to the other server.
+# Returns the list of newly allocated UIDs.
+sub callback_new_message_flush($$$@) {
+ my ($idx, $mailbox, $name, @messages) = @_;
+
+ my $imap = $name eq 'local' ? $rIMAP : $lIMAP; # target client
+ my @sUID = map {$_->{UID}} @messages;
+ my @tUID = $imap->append($mailbox, @messages);
+ die unless $#sUID == $#tUID; # sanity check
+
+ my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID);
+ for (my $k=0; $k<=$#messages; $k++) {
+ logger(undef, "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox")
+ if $CONFIG{debug};
+ $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]);
+ }
+ $DBH->commit(); # commit only once per batch
+
+ return @tUID;
+}
+
+
+# Sync both known and new messages
+# If the array references $lIgnore and $rIgnore are not empty, skip
+# the given UIDs.
+sub sync_messages($$;$$) {
+ my ($idx, $mailbox, $lIgnore, $rIgnore) = @_;
+
+ my %ignore = (local => ($lIgnore // []), remote => ($rIgnore // []));
+ my $loop;
+ do {
+ # get new messages from $source (except @{$ignore{$source}}) and APPEND them to $target
+ foreach my $source (qw/remote local/) { # pull remote mails first
+ my $target = $source eq 'remote' ? 'local' : 'remote';
+ my $buff = [] unless ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND');
+ my $bufflen = 0;
+ my @tUIDs;
+
+ ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages(sub($) {
+ callback_new_message($idx, $mailbox, $source, shift, \@tUIDs, $buff, \$bufflen)
+ }, @{$ignore{$source}});
+
+ push @tUIDs, callback_new_message_flush($idx, $mailbox, $source, @$buff)
+ if defined $buff and @$buff;
+ push @{$ignore{$target}}, @tUIDs;
+
+ $loop = @tUIDs ? 1 : 0;
+ }
+ # since $source modifies $target's UIDNEXT upon new mails, we
+ # need to check again the first $source (remote) whenever the
+ # last one (local) added new messages to it
+ }
+ while ($loop);
+
+ # both local and remote UIDNEXT are now up to date; proceed with
+ # pending flag updates and vanished messages
+ sync_known_messages($idx, $mailbox);
+
+ # don't store the new UIDNEXTs before to avoid downloading these
+ # mails again in the event of a crash
+ $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $idx) or
+ msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox");
+ $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $idx) or
+ msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox");
+ $DBH->commit();
+}
+
+
+# Wait up to $timout seconds for notifications on either IMAP server.
+# Then issue a NOOP so the connection doesn't terminate for inactivity.
+sub wait_notifications(;$) {
+ my $timeout = shift // 300;
+
+ while ($timeout > 0) {
+ my $r1 = $lIMAP->slurp();
+ my $r2 = $rIMAP->slurp();
+ last if $r1 or $r2; # got update!
+
+ sleep 1;
+ if (--$timeout == 0) {
+ $lIMAP->noop();
+ $rIMAP->noop();
+ # might have got updates so exit the loop
+ }
+ }
+}
+
+
+#############################################################################
+# Resume interrupted mailbox syncs (before initializing the cache).
+#
+my ($MAILBOX, $IDX);
+$STH_LIST_INTERRUPTED->execute();
+while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) {
+ next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailbox
+ ($IDX, $MAILBOX) = @$row;
+ msg(undef, "Resuming interrupted sync for $MAILBOX");
+
+ my %lUIDs;
+ $STH_GET_INTERRUPTED_BY_IDX->execute($IDX);
+ while (defined (my $row = $STH_GET_INTERRUPTED_BY_IDX->fetchrow_arrayref())) {
+ $lUIDs{$row->[0]} = $row->[1]; # pair ($lUID, $rUID)
+ }
+ die unless %lUIDs; # sanity check
+
+ $lIMAP->select($MAILBOX);
+ $rIMAP->select($MAILBOX);
+
+ # FETCH all messages with their FLAGS to detect messages that have
+ # vanished meanwhile, or for which there was a flag update.
+
+ my (%lList, %rList); # The lists of existing local and remote UIDs
+ my $attrs = '('.join(' ', qw/MODSEQ FLAGS/).')';
+ $lIMAP->fetch(compact_set(keys %lUIDs), $attrs, sub($){ $lList{shift->{UID}} = 1 });
+ $rIMAP->fetch(compact_set(values %lUIDs), $attrs, sub($){ $rList{shift->{UID}} = 1 });
+
+ my (@lToRemove, @rToRemove);
+ while (my ($lUID,$rUID) = each %lUIDs) {
+ next if $lList{$lUID} and $rList{$rUID}; # exists on both
+ push @lToRemove, $lUID if $lList{$lUID};
+ push @rToRemove, $rUID if $rList{$rUID};
+
+ delete_mapping($IDX, $lUID);
+ }
+
+ $lIMAP->remove_message(@lToRemove) if @lToRemove;
+ $rIMAP->remove_message(@rToRemove) if @rToRemove;
+ $DBH->commit() if @lToRemove or @rToRemove; # /!\ commit *after* remove_message!
+
+ # ignore deleted messages
+ delete @lList{@lToRemove};
+ delete @rList{@rToRemove};
+
+ # Resume the sync, but skip messages that have already been
+ # downloaded. Flag updates will be processed automatically since
+ # the _MODIFIED internal cache has been initialized with all our
+ # UIDs. (Since there is no reliable HIGHESTMODSEQ, any flag
+ # difference is treated as a conflict.)
+ sync_messages($IDX, $MAILBOX, [keys %lList], [keys %rList]);
+}
+
+
+#############################################################################
+# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
+#
+my %KNOWN_INDEXES;
+$STH_GET_CACHE->execute();
+while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
+ next unless grep {$row->{mailbox} eq $_} @MAILBOXES;
+ $lIMAP->set_cache($row->{mailbox},
+ UIDVALIDITY => $row->{lUIDVALIDITY},
+ UIDNEXT => $row->{lUIDNEXT},
+ HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ}
+ );
+ $rIMAP->set_cache($row->{mailbox},
+ UIDVALIDITY => $row->{rUIDVALIDITY},
+ UIDNEXT => $row->{rUIDNEXT},
+ HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
+ );
+ $KNOWN_INDEXES{$row->{idx}} = 1;
+}
+
+if (defined $COMMAND and $COMMAND eq 'repair') {
+ repair($_) foreach @MAILBOXES;
+ exit 0;
+}
+
+
+while(1) {
+ while(@MAILBOXES) {
+ my $cache;
+ my $update = 0;
+ if (defined $MAILBOX and ($lIMAP->is_dirty($MAILBOX) or $rIMAP->is_dirty($MAILBOX))) {
+ # $MAILBOX is dirty on either the local or remote mailbox
+ sync_messages($IDX, $MAILBOX);
+ }
+ else {
+ $MAILBOX = $lIMAP->next_dirty_mailbox(@MAILBOXES) // $rIMAP->next_dirty_mailbox(@MAILBOXES) // last;
+ $MAILBOX = 'INBOX' if uc $MAILBOX eq 'INBOX'; # INBOX is case insensitive
+
+ $STH_GET_INDEX->execute($MAILBOX);
+ ($IDX) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+ die unless defined $IDX; # sanity check;
+
+ select_mbx($IDX, $MAILBOX);
+
+ if (!$KNOWN_INDEXES{$IDX}) {
+ $STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX));
+ $STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX));
+
+ # no need to commit before the first mapping (lUID,rUID)
+ $KNOWN_INDEXES{$IDX} = 1;
+ }
+ elsif (sync_known_messages($IDX, $MAILBOX)) {
+ # sync updates to known messages before fetching new messages
+ # get_cache is safe after pull_update
+ $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or
+ msg('database', "WARNING: Can't update local HIGHESTMODSEQ for $MAILBOX");
+ $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or
+ msg('database', "WARNING: Can't update remote HIGHESTMODSEQ for $MAILBOX");
+ $DBH->commit();
+ }
+ sync_messages($IDX, $MAILBOX);
+ }
+ }
+ # clean state!
+ exit 0 unless defined $COMMAND and $COMMAND eq 'watch';
+ wait_notifications(900);
+}
+
+END {
+ $_->logout() foreach grep defined, ($lIMAP, $rIMAP);
+ cleanup();
+}
--- /dev/null
+.TH INTERIMAP "1" "JULY 2015" "InterIMAP" "User Commands"
+
+.SH NAME
+InterIMAP \- Fast two-way synchronization program for QRESYNC-capable
+IMAP servers
+
+.SH SYNOPSIS
+.B interimap\fR [\fIOPTION\fR ...] [\fICOMMAND\fR] [\fIMAILBOX\fR ...]
+
+
+.SH DESCRIPTION
+.PP
+.B InterIMAP\fR performs stateful synchronization between two IMAP4rev1
+servers.
+Such synchronization is made possible by the QRESYNC extension from
+[RFC7162]; for convenience reasons servers must also support
+LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315].
+Furthermore, while \fBInterIMAP\fR can work with servers lacking support
+for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions
+greatly improve performance by reducing the number of required round
+trips hence are recommended.
+
+.PP
+Stateful synchronization is only possible for mailboxes supporting
+persistent message Unique Identifiers (UID) and persistent storage of
+mod\-sequences (MODSEQ); any non\-compliant mailbox will cause
+\fBInterIMAP\fR to abort.
+Furthermore, because UIDs are allocated not by the client but by the
+server, \fBInterIMAP\fR needs to keep track of associations between local
+and remote UIDs for each mailbox.
+The synchronization state of a mailbox consists of its UIDNEXT and
+HIGHESTMODSEQ values on each server;
+it is then assumed that each message with UID < $UIDNEXT have been
+replicated to the other server, and that the metadata (such as flags) of
+each message with MODSEQ <= $HIGHESTMODSEQ have been synchronized.
+Conceptually, the synchronization algorithm is derived from [RFC4549]
+with the [RFC7162, section 6] amendments, and works as follows:
+
+.nr step 1 1
+.IP \n[step]. 8
+SELECT (on both servers) a mailbox the current UIDNEXT or HIGHESTMODSEQ
+values of which differ from the values found in the database (for either
+server). Use the QRESYNC SELECT parameter from [RFC7162] to list
+changes (vanished messages and flag updates) since $HIGHESTMODSEQ to
+messages with UID<$UIDNEXT.
+
+.IP \n+[step].
+Propagate these changes onto the other server: get the corresponding
+UIDs from the database, then a/ issue an UID STORE + UID EXPUNGE command
+to remove messages that have not already been deleted on both servers,
+and b/ issue UID STORE commands to propagate flag updates (send a single
+command for each flag list in order the reduce the number of round
+trips).
+(Conflicts may occur if the metadata of a message has been updated on
+both servers with different flag lists; in that case \fBInterIMAP\fR
+issues a warning and updates the message on each server with the union
+of both flag lists.)
+Repeat this step if the server sent some updates in the meantime.
+Otherwise, update the HIGHESTMODSEQ value in the database.
+
+.IP \n+[step].
+Process new messages (if the current UIDNEXT value differ from the one
+found in the database) by issuing an UID FETCH command and for each
+message RFC822 body received, issue an APPEND command to the other
+server on\-the\-fly.
+Repeat this step if the server received new messages in the meantime.
+Otherwise, update the UIDNEXT value in the database.
+Go back to step 2 if the server sent some updates in the meantime.
+
+.IP \n+[step].
+Go back to step 1 to proceed with the next unsynchronized mailbox.
+
+.SH COMMANDS
+.PP
+By default \fBInterIMAP\fR synchronizes each mailbox listed by the
+\(lqLIST "" "*"\(rq IMAP command;
+the \fIlist-mailbox\fR, \fIlist-select-opts\fR and \fIignore-mailbox\fR
+options from the configuration file can be used to shrink that list and
+save bandwidth.
+However if some extra argument are provided on the command line,
+\fBInterIMAP\fR ignores said options and synchronizes the given
+\fIMAILBOX\fRes instead. Note that each \fIMAILBOX\fR is taken \(lqas
+is\(rq; in particular, it must be UTF-7 encoded, unquoted, and the list
+wildcards \(oq*\(cq and \(oq%\(cq are not interpolated.
+
+.PP
+If the synchronization was interrupted during a previous run while some
+messages were being replicated (but before the UIDNEXT or HIGHESTMODSEQ
+values have been updated), \fBInterIMAP\fR performs a \(lqfull
+synchronization\(rq on theses messages only:
+downloading the whole UID and flag lists on each servers allows
+\fBInterIMAP\fR to detect messages that have been removed or for which
+their flags have changed in the meantime.
+Finally, after propagating the offline changes for these messages,
+\fBInterIMAP\fR resumes the synchronization for the rest of the mailbox.
+
+.PP
+Specifying one of the commands below makes \fBInterIMAP\fR perform an
+action other than the default QRESYNC-based synchronization.
+
+.TP
+.B \-\-repair \fR[\fIMAILBOX\fR ...]
+List the database anomalies and try to repair them.
+(Consider only the given \fIMAILBOX\fRes if non-optional arguments are
+provided.)
+This is done by performing a so\-called \(lqfull synchronization\(rq,
+namely 1/ download all UIDs along with their flags from both the local
+and remote servers, 2/ ensure that each entry in the database corresponds
+to an existing UID, and 3/ ensure that both flag lists match.
+Any message found on a server but not in the database is replicated on
+the other server (which in the worst case, might lead to a message
+duplicate).
+Flag conflicts are solved by updating each message to the union of both
+lists.
+
+.TP
+.B \-\-delete \fIMAILBOX\fR [...]
+Delete the given \fIMAILBOX\fRes on each target (by default each server
+plus the database, unless \fB\-\-target\fR specifies otherwise) where
+it exists.
+Note that per [RFC3501] deletion is not recursive: \fIMAILBOX\fR's
+children are not deleted.
+
+.TP
+.B \-\-rename \fISOURCE\fR \fIDEST\fR
+Rename the mailbox \fISOURCE\fR to \fIDEST\fR on each target (by default
+each server plus the database, unless \fB\-\-target\fR specifies
+otherwise) where it exists.
+\fBInterIMAP\fR aborts if \fIDEST\fR already exists on either target.
+Note that per [RFC3501] the renaming is recursive: \fISOURCE\fR's
+children are moved to become \fIDEST\fR's children instead.
+
+
+.SH OPTIONS
+.TP
+.B \-\-config=\fR\fIFILE\fR
+Specify an alternate configuration file. Relative paths start from
+\fI$XDG_CONFIG_HOME\fR, or \fI~/.config\fR if the XDG_CONFIG_HOME
+environment variable is unset.
+
+.TP
+.B \fB\-\-target=\fR{local,remote,database}
+Limit the scope of a \fB\-\-delete\fR or \fB\-\-rename\fR command
+to the given target. Can be repeated to act on multiple targets. By
+default all three targets are considered.
+
+.TP
+.B \-q\fR, \fB\-\-quiet\fR
+Try to be quiet.
+
+.TP
+.B \-\-debug
+Turn on debug mode. Debug messages are written to the given \fIlogfile\fR.
+Note that this include all IMAP traffic (except literals). Depending on the
+chosen authentication mechanism, this might include authentication credentials.
+
+.TP
+.B \-h\fR, \fB\-\-help\fR
+Output a brief help and exit.
+
+.TP
+.B \-\-version
+Show the version number and exit.
+
+.SH CONFIGURATION FILE
+
+Unless told otherwise by the \fB\-\-config=\fR\fIFILE\fR option,
+\fBInterIMAP\fR reads its configuration from
+\fI$XDG_CONFIG_HOME/interimap\fR (or \fI~/.config/interimap\fR if the
+XDG_CONFIG_HOME environment variable is unset) as an INI file.
+The syntax of the configuration file is a serie of
+\fIOPTION\fR=\fIVALUE\fR lines organized under some \fI[SECTION]\fR;
+lines starting with a \(oq#\(cq or \(oq;\(cq character are ignored as
+comments.
+The sections \(lq[local]\(rq and \(lq[remote]\(rq define the two IMAP
+servers to synchronize.
+Valid options are:
+
+.TP
+.I database
+SQLite version 3 database file to use to keep track of associations
+between local and remote UIDs, as well as the UIDVALIDITY, UIDNEXT and
+HIGHESTMODSEQ of each known mailbox on both servers.
+Relative paths start from \fI$XDG_DATA_HOME/interimap\fR, or
+\fI~/.local/share/interimap\fR if the XDG_DATA_HOME environment variable
+is unset.
+This option is only available in the default section.
+(Default: \(lq\fIhost\fR.db\)\(rq, where \fIhost\fR is taken from the
+\(lq[remote]\(rq or \(lq[local]\(rq sections, in that order.)
+
+.TP
+.I list-mailbox
+A space separated list of mailbox patterns to use when issuing the
+initial LIST command (overridden by the \fIMAILBOX\fRes given as
+command-line arguments).
+Note that each pattern containing special characters such as spaces or
+brackets (see [RFC3501] for the exact syntax) must be quoted.
+Furthermore, non-ASCII names must be UTF\-7 encoded.
+Two wildcards are available: a \(oq*\(cq character matches zero or more
+characters, while a \(oq%\(cq character matches zero or more characters
+up to the mailbox's hierarchy delimiter.
+This option is only available in the default section.
+(The default pattern, \(lq*\(rq, matches all visible mailboxes on the
+server.)
+
+.TP
+.I list-select-opts
+An optional space separated list of selectors for the initial LIST
+command. (Requires a server supporting the LIST-EXTENDED [RFC5258]
+extension.) Useful values are
+\(lqSUBSCRIBED\(rq (to list only subscribed mailboxes),
+\(lqREMOTE\(rq (to also list remote mailboxes on a server supporting
+mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes
+with children matching one of the \fIlist-mailbox\fR patterns above).
+This option is only available in the default section.
+
+.TP
+.I ignore-mailbox
+An optional Perl Compatible Regular Expressions (PCRE) covering
+mailboxes to exclude:
+any (UTF-7 encoded, unquoted) mailbox listed in the initial LIST
+responses is ignored if it matches the given expression.
+Note that the \fIMAILBOX\fRes given as command-line arguments bypass the
+check and are always considered for synchronization.
+This option is only available in the default section.
+
+.TP
+.I logfile
+A file name to use to log debug and informational messages. This option is
+only available in the default section.
+
+.TP
+.I type
+One of \(lqimap\(rq, \(lqimaps\(rq or \(lqtunnel\(rq.
+\fItype\fR=imap and \fItype\fR=imaps are respectively used for IMAP and
+IMAP over SSL/TLS connections over a INET socket.
+\fItype\fR=tunnel causes \fBInterIMAP\fR to open a pipe to a
+\fIcommand\fR instead of a raw socket.
+Note that specifying \fItype\fR=tunnel in the \(lq[remote]\(rq section
+makes the default \fIdatabase\fR to be \(lqlocalhost.db\(rq.
+(Default: \(lqimaps\(rq.)
+
+.TP
+.I host
+Server hostname, for \fItype\fR=imap and \fItype\fR=imaps.
+(Default: \(lqlocalhost\(rq.)
+
+.TP
+.I port
+Server port.
+(Default: \(lq143\(rq for \fItype\fR=imap, \(lq993\(rq for
+\fItype\fR=imaps.)
+
+.TP
+.I command
+Command to use for \fItype\fR=tunnel. Must speak the IMAP4rev1 protocol
+on its standard output, and understand it on its standard input.
+
+.TP
+.I STARTTLS
+Whether to use the \(lqSTARTTLS\(rq directive to upgrade to a secure
+connection. Setting this to \(lqYES\(rq for a server not advertising
+the \(lqSTARTTLS\(rq capability causes \fBInterIMAP\fR to immediately
+abort the connection.
+(Ignored for \fItype\fRs other than \(lqimap\(rq. Default: \(lqYES\(rq.)
+
+.TP
+.I auth
+Space\-separated list of preferred authentication mechanisms.
+\fBInterIMAP\fR uses the first mechanism in that list that is also
+advertised (prefixed with \(lqAUTH=\(rq) in the server's capability list.
+Supported authentication mechanisms are \(lqPLAIN\(rq and \(lqLOGIN\(rq.
+(Default: \(lqPLAIN LOGIN\(rq.)
+
+.TP
+.I username\fR, \fIpassword\fR
+Username and password to authenticate with. Can be required for non
+pre\-authenticated connections, depending on the chosen authentication
+mechanism.
+
+.TP
+.I SSL_cipher_list
+Cipher list to use for the connection.
+See \fIciphers\fR(1ssl) for the format of such list.
+
+.TP
+.I SSL_fingerprint
+Fingerprint of the server certificate in the form
+\fIALGO\fR$\fIDIGEST_HEX\fR, where \fIALGO\fR is the used algorithm
+(default \(lqsha256\(rq).
+Attempting to connect to a server with a non-matching certificate
+fingerprint causes \fBInterIMAP\fR to abort the connection immediately
+after the SSL/TLS handshake.
+
+.TP
+.I SSL_verify_trusted_peer
+Whether to verify that the peer certificate has been signed by a trusted
+Certificate Authority. Note that using \fISSL_fingerprint\fR to specify
+the fingerprint of the server certificate is orthogonal and does not
+rely on Certificate Authorities.
+(Default: \(lqYES\(rq.)
+
+.TP
+.I SSL_ca_path
+Directory containing the certificate(s) of the trusted Certificate
+Authorities, used for server certificate verification.
+
+.SH KNOWN BUGS AND LIMITATIONS
+
+.IP \[bu]
+Using \fBInterIMAP\fR on two identical servers with a non-existent or
+empty database will duplicate each message due to the absence of
+local/remote UID association.
+.IP \[bu]
+\fBInterIMAP\fR is single threaded and doesn't use IMAP command
+pipelining. Synchronization could be boosted up by sending independent
+commands (such as the initial LIST/STATUS command) to each server in
+parallel, and for a given server, by sending independent commands (such
+as flag updates) in a pipeline.
+.IP \[bu]
+Because the IMAP protocol doesn't have a specific response code for when
+a message is moved to another mailbox (using the MOVE command from
+[RFC6851] or COPY + STORE + EXPUNGE), moving a messages causes
+\fBInterIMAP\fR to believe that it was deleted while another one (which
+is replicated again) was added to the other mailbox in the meantime.
+
+.IP \[bu]
+\(lqPLAIN\(rq and \(lqLOGIN\(rq are the only authentication mechanisms
+currently supported.
+
+.SH AUTHOR
+Written by Guilhem Moulin
+.MT guilhem@fripost.org
+.ME .
--- /dev/null
+# database = imap.guilhem.org.db
+#list-mailbox = "*"
+list-select-opts = SUBSCRIBED
+ignore-mailbox = ^virtual/
+
+[local]
+type = tunnel
+command = /usr/lib/dovecot/imap
+
+[remote]
+# type = imaps
+host = imap.guilhem.org
+# port = 993
+username = guilhem
+password = xxxxxxxxxxxxxxxx
+
+# SSL options
+#SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
+#SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605
+#SSL_verify_trusted_peer = YES
+SSL_ca_path = /etc/ssl/certs
+
+# vim:ft=dosini
--- /dev/null
+[Unit]
+Description=Fast two-way synchronization program for QRESYNC-capable IMAP servers
+Wants=network-online.target
+After=network-online.target
+
+[Service]
+ExecStart=/usr/bin/interimap
+RestartSec=60s
+Restart=always
+
+[Install]
+WantedBy=default.target
--- /dev/null
+#----------------------------------------------------------------------
+# A minimal IMAP4 client for QRESYNC-capable servers
+# Copyright © 2015 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
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#----------------------------------------------------------------------
+
+package Net::IMAP::InterIMAP v0.0.1;
+use warnings;
+use strict;
+
+use Config::Tiny ();
+use IO::Select ();
+use List::Util 'first';
+use Socket 'SO_KEEPALIVE';
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/;
+}
+
+
+# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'.
+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]/;
+
+# Map each option to a regexp validating its values.
+my %OPTIONS = (
+ host => qr/\A([0-9a-zA-Z:.-]+)\z/,
+ port => qr/\A([0-9]+)\z/,
+ type => qr/\A(imaps?|tunnel)\z/,
+ STARTTLS => qr/\A(YES|NO)\z/i,
+ username => qr/\A([\x01-\x7F]+)\z/,
+ password => qr/\A([\x01-\x7F]+)\z/,
+ auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
+ command => qr/\A(\/\P{Control}+)\z/,
+ SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
+ SSL_cipher_list => qr/\A(\P{Control}+)\z/,
+ SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
+ SSL_ca_path => qr/\A(\P{Control}+)\z/,
+);
+
+
+#############################################################################
+# Utilities
+
+# read_config($conffile, $sections, %opts)
+# Read $conffile's default section, then each section in the array
+# reference $section (which takes precedence). %opts extends %OPTIONS
+# and maps each option to a regexp validating its values.
+sub read_config($$%) {
+ my $conffile = shift;
+ 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;
+
+ my $h = Config::Tiny::->read($conffile);
+
+ my %configs;
+ foreach my $section (@$sections) {
+ my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section
+ $configs{$section} = $conf;
+
+ if ($section ne '_') {
+ die "No such section $section\n" unless defined $h->{$section};
+ $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
+ }
+
+ # default values
+ $conf->{type} //= 'imaps';
+ $conf->{host} //= 'localhost';
+ $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef;
+ $conf->{auth} //= 'PLAIN LOGIN';
+ $conf->{STARTTLS} //= 'YES';
+
+ # untaint and validate the config
+ foreach my $k (keys %$conf) {
+ die "Invalid option $k\n" unless defined $opts{$k};
+ next unless defined $conf->{$k};
+ die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
+ $conf->{$k} = $1;
+ }
+ }
+ return \%configs;
+}
+
+
+# compact_set(@set).
+# Compact the UID or sequence number set @set, which must be
+# non-empty and may not contain '*'. (Duplicates are allowed, but
+# are removed).
+sub compact_set(@) {
+ my @set = sort {$a <=> $b} @_;
+ my $min = my $max = shift @set // die 'Empty range';
+ my $set;
+
+ while (@set) {
+ my $k = shift @set;
+ if ($k < $max) {
+ die "Non-sorted range: $k < $max"; # sanity check
+ }
+ elsif ($k == $max) { # skip duplicates
+ }
+ elsif ($k == $max + 1) {
+ $max++;
+ }
+ else {
+ $set .= ',' if defined $set;
+ $set .= $min == $max ? $min : "$min:$max";
+ $min = $max = $k;
+ }
+ }
+
+ $set .= ',' if defined $set;
+ $set .= $min == $max ? $min : "$min:$max";
+ return $set;
+}
+
+
+# in_set($x, $set)
+# Return true if the UID or sequence number $x belongs to the set $set.
+# /!\ The highest number in the mailbox, "*" should not appear by
+# itself (other than in a range).
+sub in_set($$) {
+ my ($x, $set) = @_;
+ foreach my $r (split /,/, $set) {
+ if ($r =~ /\A([0-9]+)\z/) {
+ return 1 if $x == $1;
+ }
+ elsif ($r eq '*' or $r eq '*:*') {
+ warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
+ return 1;
+ }
+ elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) {
+ return 1 if $1 <= $x;
+ }
+ elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) {
+ my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1);
+ return 1 if $min <= $x and $x <= $max;
+ }
+ }
+ return 0;
+}
+
+
+# quote($str)
+# Quote the given string if needed, or make it a (synchronizing)
+# literal. The literals will later be made non-synchronizing if the
+# server is LITERAL+-capable (RFC 2088).
+sub quote($) {
+ my $str = shift;
+ if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) {
+ return $str;
+ }
+ elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) {
+ $str =~ s/([\x22\x5C])/\\$1/g;
+ return "\"$str\"";
+ }
+ else {
+ return "{".length($str)."}\r\n".$str;
+ }
+}
+
+
+
+#############################################################################
+# Public interface
+# /!\ While this module can be used with non QRESYNC-capable (or non
+# QRESYNC-enabled) servers, there is no internal cache mapping sequence
+# numbers to UIDs, so EXPUNGE responses are ignored.
+
+# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status
+# ('OK'/'NO'/'BAD') condition for the last command issued.
+our $IMAP_cond;
+
+# The response text for the last command issued (prefixed with the status
+# condition but without the tag).
+our $IMAP_text;
+
+
+# Create a new Net::IMAP::InterIMAP object. Connect to the server,
+# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and
+# update the CAPABILITY list.
+# In addition to the %OPTIONS above, valid parameters include:
+#
+# - 'debug': Enable debug messages.
+#
+# - 'enable': An extension or array reference of extensions to ENABLE
+# (RFC 5161) after entering AUTH state. Croak if the server did not
+# advertise "ENABLE" in its CAPABILITY list or does not reply with
+# an untagged ENABLED response with all the given extensions.
+#
+# - 'name': An optional instance name to include in log messages.
+#
+# - 'extra-attrs': An attribute or list of extra attributes to FETCH
+# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
+# BODY.PEEK[]).
+#
+# - 'logger-fd': An optional filehandle to use for debug output.
+#
+sub new($%) {
+ my $class = shift;
+ my $self = { @_ };
+ bless $self, $class;
+
+ # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
+ # (cf RFC 3501 section 3)
+ $self->{_STATE} = '';
+
+ if ($self->{type} eq 'tunnel') {
+ require 'IPC/Open2.pm';
+ my $command = $self->{command} // $self->fail("Missing tunnel command");
+ my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, $command)
+ or $self->panic("Can't fork: $!");
+ }
+ else {
+ my %args = (Proto => 'tcp', Blocking => 1);
+ $args{PeerHost} = $self->{host} // $self->fail("Missing option host");
+ $args{PeerPort} = $self->{port} // $self->fail("Missing option port");
+
+ my $socket;
+ if ($self->{type} eq 'imap') {
+ require 'IO/Socket/INET.pm';
+ $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
+ }
+ else {
+ require 'IO/Socket/SSL.pm';
+ if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) {
+ $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO';
+ }
+ my $fpr = delete $self->{SSL_fingerprint};
+ $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
+ $socket = IO::Socket::SSL->new(%args)
+ or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
+
+ # ensure we're talking to the right server
+ $self->_fingerprint_match($socket, $fpr) if defined $fpr;
+ }
+
+ $socket->sockopt(SO_KEEPALIVE, 1);
+ $self->{$_} = $socket for qw/STDOUT STDIN/;
+ }
+ $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!");
+
+ # command counter
+ $self->{_TAG} = 0;
+
+ # internal cache, constantly updated to reflect the current server
+ # state for each mailbox
+ $self->{_CACHE} = {};
+
+ # persistent cache, describing the last clean (synced) state
+ $self->{_PCACHE} = {};
+
+ # list of UIDs for which the server a VANISHED or VANISHED (EARLIER)
+ # response. /!\ requires a QRESYNC-capable server!
+ # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
+ # are considered.
+ $self->{_VANISHED} = [];
+
+ # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH
+ # response with the FLAGS attribute. The \Recent flag is always
+ # omitted from the FLAG list. MODSEQ is always present, and the
+ # value [ MODSEQ, FLAGS ] is updated if another FETCH response with
+ # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG
+ # list of the message is considered unknown and should be retrieved
+ # manually.
+ # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
+ # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ}
+ # are considered.
+ $self->{_MODIFIED} = {};
+
+ if (defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR) {
+ require 'POSIX.pm';
+ require 'Time/HiRes.pm';
+ }
+
+ # wait for the greeting
+ my $x = $self->_getline();
+ $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x);
+ $IMAP_cond = $1;
+ $IMAP_text = $1.' '.$x;
+
+ # try to update the cache (eg, capabilities)
+ $self->_resp_text($x);
+
+ if ($IMAP_cond eq 'OK') {
+ # login required
+ $self->{_STATE} = 'UNAUTH';
+ my @caps = $self->capabilities();
+
+ if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1
+ $self->fail("Server did not advertise STARTTLS capability.")
+ unless grep {$_ eq 'STARTTLS'} @caps;
+
+ require 'IO/Socket/SSL.pm';
+ $self->_send('STARTTLS');
+
+ my %sslargs;
+ if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) {
+ $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO';
+ }
+ my $fpr = delete $self->{SSL_fingerprint};
+ $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
+ IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs)
+ or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
+
+ # ensure we're talking to the right server
+ $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr;
+
+ # refresh the previous CAPABILITY list since the previous one could have been spoofed
+ delete $self->{_CAPABILITIES};
+ @caps = $self->capabilities();
+ }
+
+ my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps);
+ my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef}
+ split(/ /, $self->{auth}))[0];
+ $self->fail("Failed to choose an authentication mechanism") unless defined $mech;
+ $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and
+ grep {$_ eq 'LOGINDISABLED'} @caps;
+
+ my ($command, $callback);
+ my ($username, $password) = @$self{qw/username password/};
+
+ if ($mech eq 'LOGIN') {
+ $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
+ $command = join ' ', 'LOGIN', quote($username), quote($password);
+ }
+ elsif ($mech eq 'PLAIN') {
+ require 'MIME/Base64.pm';
+ $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
+ my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, '');
+ $command = "AUTHENTICATE $mech";
+ if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR
+ $command .= " $credentials";
+ } else {
+ $callback = sub($) {return $credentials};
+ }
+ }
+ else {
+ $self->fail("Unsupported authentication mechanism: $mech");
+ }
+
+ delete $self->{password}; # no need to remember passwords
+ $self->_send($command, $callback);
+ unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) {
+ # refresh the CAPABILITY list since the previous one had only pre-login capabilities
+ delete $self->{_CAPABILITIES};
+ $self->capabilities();
+ }
+ }
+
+ $self->{_STATE} = 'AUTH';
+ my @extensions = !defined $self->{enable} ? ()
+ : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}}
+ : ($self->{enable});
+ if (@extensions) {
+ $self->fail("Server did not advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE');
+ $self->_send('ENABLE '.join(' ',@extensions));
+ my @enabled = @{$self->{_ENABLED} // []};
+ $self->fail("Couldn't ENABLE $_") foreach
+ grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions;
+ }
+
+ return $self;
+}
+
+
+# Log out when the Net::IMAP::InterIMAP object is destroyed.
+sub DESTROY($) {
+ my $self = shift;
+ foreach (qw/STDIN STDOUT/) {
+ $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
+ }
+}
+
+
+# $self->log($message, [...])
+# $self->logger($message, [...])
+# Log a $message. The latter method is used to log in the 'logger-fd', and
+# add timestamps.
+sub log($@) {
+ my $self = shift;
+ return unless @_;
+ $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR;
+ my $prefix = defined $self->{name} ? $self->{name} : '';
+ $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
+ print STDERR $prefix, ': ', @_, "\n";
+}
+sub logger($@) {
+ my $self = shift;
+ return unless @_ and defined $self->{'logger-fd'};
+ my $prefix = '';
+ if ($self->{'logger-fd'}->fileno != fileno STDERR) {
+ my ($s, $us) = Time::HiRes::gettimeofday();
+ $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us ";
+ }
+ $prefix .= defined "$self->{name}" ? $self->{name} : '';
+ $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
+ $self->{'logger-fd'}->say($prefix, ': ', @_);
+}
+
+
+# $self->warn($warning, [...])
+# Log a $warning.
+sub warn($$@) {
+ my $self = shift;
+ $self->log('WARNING: ', @_);
+}
+
+
+# $self->fail($error, [...])
+# Log an $error and exit with return value 1.
+sub fail($$@) {
+ my $self = shift;
+ $self->log('ERROR: ', @_);
+ exit 1;
+}
+
+
+# $self->panic($error, [...])
+# Log a fatal $error including the position of the caller, and exit
+# with return value 255.
+sub panic($@) {
+ my $self = shift;
+ my @loc = caller;
+ my $msg = "PANIC at line $loc[2] in $loc[1]";
+ $msg .= ': ' if @_;
+ $self->log($msg, @_);
+ exit 255;
+}
+
+
+# $self->capabilities()
+# Return the capability list of the IMAP4 server. The list is cached,
+# and a CAPABILITY command is only issued if the cache is empty.
+sub capabilities($) {
+ my $self = shift;
+ $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}};
+ $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1');
+ return @{$self->{_CAPABILITIES}};
+}
+
+
+# $self->incapable(@capabilities)
+# In list context, return the list capabilties from @capabilities
+# which were NOT advertised by the server. In scalar context, return
+# the length of said list.
+sub incapable($@) {
+ my ($self, @caps) = @_;
+ my @mycaps = $self->capabilities();
+ grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps;
+}
+
+
+# $self->search($criterion)
+# Issue an UID SEARCH command with the given $criterion. Return the
+# list of matching UIDs.
+sub search($$) {
+ my ($self, $crit) = @_;
+ my @res;
+ $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_});
+ return @res
+}
+
+
+# $self->select($mailbox, [$seqs, $UIDs])
+# $self->examine($mailbox, [$seqs, $UIDs])
+# Issue a SELECT or EXAMINE command for the $mailbox. Upon success,
+# change the state to SELECTED, otherwise go back to AUTH.
+# The optional $seqs and $UIDs are used as Message Sequence Match
+# Data for the QRESYNC parameter to the SELECT command.
+sub select($$;$$) {
+ my $self = shift;
+ my $mailbox = shift;
+ $self->_select_or_examine('SELECT', $mailbox, @_);
+}
+sub examine($$;$$) {
+ my $self = shift;
+ my $mailbox = shift;
+ $self->_select_or_examine('EXAMINE', $mailbox, @_);
+}
+
+
+# $self->logout()
+# Issue a LOGOUT command. Change the state to LOGOUT.
+sub logout($) {
+ my $self = shift;
+ # don't bother if the connection is already closed
+ $self->_send('LOGOUT') if $self->{STDIN}->opened();
+ $self->{_STATE} = 'LOGOUT';
+ undef $self;
+}
+
+
+# $self->noop()
+# Issue a NOOP command.
+sub noop($) {
+ shift->_send('NOOP');
+}
+
+
+# $self->create($mailbox, [$try])
+# $self->delete($mailbox, [$try])
+# CREATE or DELETE $mailbox.
+# If try is set, print a warning but don't crash if the command fails.
+sub create($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("CREATE ".quote($mailbox));
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Created mailbox ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
+}
+sub delete($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("DELETE ".quote($mailbox));
+ delete $self->{_CACHE}->{$mailbox};
+ delete $self->{_PCACHE}->{$mailbox};
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
+}
+
+
+# $self->rename($oldname, $newname, [$try])
+# RENAME the mailbox $oldname to $newname.
+# If $try is set, print a warning but don't crash if the command fails.
+# /!\ Requires a LIST command to be issued to determine the hierarchy
+# delimiter and the mailbox attributes for the original name.
+sub rename($$$;$) {
+ my ($self, $from, $to, $try) = @_;
+ my ($delim, @attrs);
+ if ($self->{_CACHE}->{$from}) {
+ $delim = $self->{_CACHE}->{$from}->{DELIMITER};
+ @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []};
+ }
+ my $r = $self->_send("RENAME ".quote($from).' '.quote($to));
+ $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from};
+ $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from};
+ if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) {
+ # on non-flat mailboxes, move children as well (cf 3501)
+ foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) {
+ my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r;
+ $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1};
+ $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1};
+ }
+ }
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
+}
+
+
+# $self->subscribe($mailbox, [$try])
+# $self->unsubscribe($mailbox, [$try])
+# SUBSCRIBE or UNSUBSCRIBE $mailbox.
+# If $try is set, print a warning but don't crash if the command fails.
+sub subscribe($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("SUBSCRIBE ".quote($mailbox));
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Subscribe to ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
+}
+sub unsubscribe($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox));
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
+}
+
+
+# $self->list($criterion, @parameters)
+# Issue a LIST command with the given $criterion and @parameters.
+# Return a pair where the first component is a hash reference of
+# matching mailboxes and their flags, and the second component is a
+# hash reference of matching mailboxes and their hierarchy delimiter
+# (or undef for flat mailboxes).
+sub list($$@) {
+ my $self = shift;
+ my $crit = shift;
+ my %mailboxes;
+ my %delims;
+ $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''),
+ sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} );
+ return (\%mailboxes, \%delims);
+}
+
+
+# $self->remove_message($uid, [...])
+# Remove the given $uid list. Croak if the server did not advertise
+# "UIDPLUS" (RFC 4315) in its CAPABILITY list.
+# Successfully EXPUNGEd UIDs are removed from the pending VANISHED and
+# MODIFIED lists.
+# Return the list of UIDs that couldn't be EXPUNGEd.
+sub remove_message($@) {
+ my $self = shift;
+ my @set = @_;
+ $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
+ if $self->incapable('UIDPLUS');
+
+ my $set = compact_set(@set);
+ $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
+ $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS
+
+ my %vanished = map {$_ => 1} @{$self->{_VANISHED}};
+
+ my (@failed, @expunged);
+ foreach my $uid (@set) {
+ if (exists $vanished{$uid}) {
+ push @expunged, $uid
+ } else {
+ push @failed, $uid;
+ }
+ }
+
+ # ignore succesfully EXPUNGEd messages
+ delete @vanished{@expunged};
+ delete @{$self->{_MODIFIED}}{@expunged};
+ $self->{_VANISHED} = [ keys %vanished ];
+
+ $self->log("Removed ".($#expunged+1)." message(s), ".
+ "UID ".compact_set(@expunged)) if @expunged and !$self->{quiet};
+ $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed;
+ return @failed;
+}
+
+
+# $self->append($mailbox, $mail, [...])
+# Issue an APPEND command with the given mails. Croak if the server
+# did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list.
+# Providing multiple mails is only allowed for servers advertising
+# "MULTIAPPEND" (RFC 3502) in their CAPABILITY list.
+# Return the list of UIDs allocated for the new messages.
+sub append($$@) {
+ my $self = shift;
+ my $mailbox = shift;
+ return unless @_;
+ $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
+ if $self->incapable('UIDPLUS');
+
+ my @appends;
+ foreach my $mail (@_) {
+ my $append = '';
+ $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') '
+ if defined $mail->{FLAGS};
+ $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
+ $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822};
+ push @appends, $append;
+ }
+ $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.")
+ if $#appends > 0 and $self->incapable('MULTIAPPEND');
+
+ # dump the cache before issuing the command if we're appending to the current mailbox
+ my ($UIDNEXT, $EXISTS, $cache, %vanished);
+ if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
+ $cache = $self->{_CACHE}->{$mailbox};
+ $UIDNEXT = $cache->{UIDNEXT} // $self->panic();
+ $EXISTS = $cache->{EXISTS} // $self->panic();
+ %vanished = map {$_ => 1} @{$self->{_VANISHED}};
+ }
+
+ $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends));
+ $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text);
+ my ($uidvalidity, $uidset) = ($1, $2);
+ $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity);
+
+ my @uids;
+ foreach (split /,/, $uidset) {
+ if (/\A([0-9]+)\z/) {
+ $UIDNEXT = $1 + 1 if defined $UIDNEXT and $UIDNEXT <= $1;
+ push @uids, $1;
+ } elsif (/\A([0-9]+):([0-9]+)\z/) {
+ my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1);
+ push @uids, ($min .. $max);
+ $UIDNEXT = $max + 1 if defined $UIDNEXT and $UIDNEXT <= $max;
+ } else {
+ $self->panic($_);
+ }
+ }
+ $self->fail("$uidset contains ".scalar(@uids)." elements while "
+ .scalar(@appends)." messages were appended.")
+ unless $#uids == $#appends;
+
+ # if $mailbox is the current mailbox we need to update the cache
+ if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
+ # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required
+ my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}};
+ delete $vanished2{$_} foreach keys %vanished;
+ my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile
+ $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS;
+ $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT;
+ }
+
+ $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids))
+ unless $self->{quiet};
+ return @uids;
+}
+
+
+# $self->fetch($set, $flags, [$callback])
+# Issue an UID FETCH command with the given UID $set, $flags, and
+# optional $callback.
+sub fetch($$$$) {
+ my ($self, $set, $flags, $callback) = @_;
+ $self->_send("UID FETCH $set $flags", $callback);
+}
+
+
+# $self->notify(@specifications)
+# Issue a NOTIFY command with the given mailbox @specifications (cf RFC
+# 5465 section 6) to be monitored. Croak if the server did not
+# advertise "NOTIFY" (RFC 5465) in its CAPABILITY list.
+sub notify($@) {
+ my $self = shift;
+ $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.")
+ if $self->incapable('NOTIFY');
+ my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/;
+ # Be notified of new messages with EXISTS/RECENT responses, but
+ # don't receive unsolicited FETCH responses with a RFC822/BODY[].
+ # It costs us an extra roundtrip, but we need to sync FLAG updates
+ # and VANISHED responses in batch mode, update the HIGHESTMODSEQ,
+ # and *then* issue an explicit UID FETCH command to get new message,
+ # and process each FETCH response with a RFC822/BODY[] attribute as
+ # they arrive.
+ my $command = 'NOTIFY ';
+ $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
+ $self->_send($command);
+ $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT});
+}
+
+
+# $self->slurp()
+# See if the server has sent some unprocessed data; try to as many
+# lines as possible, process them, and return the number of lines
+# read.
+# This is mostly useful when waiting for notifications while no
+# command is progress, cf. RFC 5465 (NOTIFY).
+sub slurp($) {
+ my $self = shift;
+
+ my $stdout = $self->{STDOUT};
+ my $read = 0;
+
+ while (1) {
+ # Unprocessed data within the current SSL frame would cause
+ # select(2) to block/timeout due to the raw socket not being
+ # ready.
+ unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) {
+ my ($ok) = $self->{_SEL_OUT}->can_read(0);
+ return $read unless defined $ok;
+ }
+
+ $self->_resp( $self->_getline() );
+ $read++;
+ }
+}
+
+
+# $self->set_cache( $mailbox, STATE )
+# Initialize or update the persistent cache, that is, associate a
+# known $mailbox with the last known (synced) state:
+# * UIDVALIDITY
+# * UIDNEXT: Any message the UID of which is at least UIDNEXT is
+# considered new and must be downloaded. (If 0 or missing, all
+# messages in $mailbox are considered new.) Note that while all
+# UIDs in the map are <UIDNEXT, the message with UID UIDNEXT-1 may
+# have been deleted hence may no longer be present in $mailbox.
+# * HIGHESTMODSEQ: Any change with MODSEQ <= HIGHESTMODSEQ have been
+# processed. (Note however that new messages may have a lower
+# MODSEQ.) Always present when UIDNEXT is present.
+sub set_cache($$%) {
+ my $self = shift;
+ my $mailbox = shift // $self->panic();
+ my $cache = $self->{_PCACHE}->{$mailbox} //= {};
+
+ my %status = @_;
+ while (my ($k, $v) = each %status) {
+ if ($k eq 'UIDVALIDITY') {
+ # try to detect UIDVALIDITY changes early (before starting the sync)
+ $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ",
+ "Need to invalidate the UID cache.")
+ if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
+ }
+ $cache->{$k} = $v;
+ }
+
+ $self->logger("Update last clean state for $mailbox: ".
+ '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')')
+ if $self->{debug};
+}
+
+
+# $self->uidvalidity([$mailbox])
+# Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to
+# its UIDVALIDITY if $mailbox is omitted.
+sub uidvalidity($;$) {
+ my $self = shift;
+ my $mailbox = shift;
+ if (defined $mailbox) {
+ my $cache = $self->{_CACHE}->{$mailbox} // return;
+ return $cache->{UIDVALIDITY};
+ }
+ else {
+ my %uidvalidity;
+ while (my ($mbx,$cache) = each %{$self->{_CACHE}}) {
+ $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0;
+ }
+ return %uidvalidity;
+ }
+}
+
+
+# $self->set_cache(@attributes)
+# Return the persistent cache for the mailbox currently selected. If
+# some @attributes are given, return the list of values corresponding
+# to these attributes.
+# /!\ Should only be called right after pull_updates!
+# Croak if there are unprocessed VANISHED responses or FLAG updates.
+sub get_cache($@) {
+ my $self = shift;
+ $self->fail("Invalid method 'get_cache' in state $self->{_STATE}")
+ unless $self->{_STATE} eq 'SELECTED';
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+
+ $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}};
+ $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}};
+
+ my $cache = $self->{_PCACHE}->{$mailbox};
+ return @_ ? @$cache{@_} : %$cache;
+}
+
+
+# $self->is_dirty($mailbox)
+# Return true if there are pending updates for $mailbox, i.e., its
+# internal cache is newer than its persistent cache.
+sub is_dirty($$) {
+ my ($self, $mailbox) = @_;
+ my $cache = $self->{_CACHE}->{$mailbox} // return 1;
+ my $pcache = $self->{_PCACHE}->{$mailbox} // return 1;
+
+ if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ}
+ and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and
+ defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT}
+ and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+
+# $self->next_dirty_mailbox(@mailboxes)
+# Return the name of a dirty mailbox, or undef if all mailboxes are
+# clean. If @mailbox is non-empty, only consider mailboxes in that
+# list.
+sub next_dirty_mailbox($@) {
+ my $self = shift;
+ my %mailboxes = map {$_ => 1} @_;
+ my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) }
+ keys %{$self->{_CACHE}};
+ if ($self->{debug}) {
+ @dirty ? $self->logger("Dirty mailboxes: ".join(', ', @dirty))
+ : $self->logger("Clean state!");
+ }
+ return $dirty[0];
+}
+
+
+# $self->pull_updates([$full])
+# If $full is set, FETCH FLAGS and MODSEQ for each UID up to
+# UIDNEXT-1.
+# Get pending updates (unprocessed VANISHED responses and FLAG
+# updates), and empty these lists from the cache.
+# Finally, update the HIGHESTMODSEQ from the persistent cache to the
+# value found in the internal cache.
+sub pull_updates($;$) {
+ my $self = shift;
+ my $full = shift // 0;
+ 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;
+ while (%{$self->{_MODIFIED}}) {
+ 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
+ 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
+ $modified{$uid} = $full ? $v : $v->[1];
+ } else {
+ push @missing, $uid;
+ }
+ }
+ $self->{_MODIFIED} = {};
+ $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
+ my %vanished = map {$_ => 1} grep { $_ < ($pcache->{UIDNEXT} // 1) } @{$self->{_VANISHED}};
+ my @vanished = keys %vanished;
+ $self->{_VANISHED} = [];
+
+ # ignore FLAG updates on VANISHED messages
+ delete @modified{@vanished};
+
+ # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT
+ # since there might be new messages)
+ $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ});
+
+ return (\@vanished, \%modified);
+}
+
+
+# $self->pull_new_messages($callback, @ignore)
+# FETCH new messages since the UIDNEXT found in the persistent cache
+# (or 1 in no such UIDNEXT is found), and process each response on the
+# fly with the callback.
+# If an @ignore list is supplied, then these messages are ignored from
+# the UID FETCH range.
+# Finally, update the UIDNEXT from the persistent cache to the value
+# found in the internal cache.
+# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ!
+sub pull_new_messages($$@) {
+ my $self = shift;
+ my $callback = shift;
+ my @ignore = sort { $a <=> $b } @_;
+ my @attrs = !defined $self->{'extra-attrs'} ? ()
+ : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}}
+ : ($self->{'extra-attrs'});
+ my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]';
+
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+
+ my $UIDNEXT;
+ do {
+ my $range = '';
+ my $first;
+ my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1;
+ foreach my $uid (@ignore) {
+ if ($since < $uid) {
+ $first //= $since;
+ $range .= ',' if $range ne '';
+ $range .= $since;
+ $range .= ':'.($uid-1) if $since < $uid-1;
+ $since = $uid+1;
+ }
+ elsif ($since == $uid) {
+ $since++;
+ }
+ }
+
+ $first //= $since;
+ $range .= ',' if $range ne '';
+ # 2^32-1: don't use '*' since the highest UID can be known already
+ $range .= "$since:4294967295";
+
+ $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT} // $self->panic(); # sanity check
+ $self->_send("UID FETCH $range ($attrs)", sub($) {
+ my $mail = shift;
+ $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID};
+ $callback->($mail) if defined $callback;
+ }) if $first < $UIDNEXT;
+
+ # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ
+ # since there might be pending updates)
+ $self->set_cache($mailbox, UIDNEXT => $UIDNEXT);
+ }
+ # loop if new messages were received in the meantime
+ while ($UIDNEXT < $self->{_CACHE}->{$mailbox}->{UIDNEXT});
+}
+
+
+# $self->push_flag_updates($flags, @set)
+# Change the flags to each UID in @set to $flags.
+# A flag update fails for mails being updated after the HIGHESTMODSEQ
+# found in the persistent cache; push such messages to the MODIFIED
+# list.
+sub push_flag_updates($$@) {
+ my $self = shift;
+ my $flags = shift;
+ my @set = @_;
+
+ 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 %failed;
+ 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) {
+ 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};
+ }
+ 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;
+ }
+ return keys %failed;
+}
+
+
+#############################################################################
+# Private methods
+
+
+# $self->_fingerprint_match($socket, $fingerprint)
+# Croak unless the fingerprint of the peer certificate of the
+# IO::Socket::SSL object doesn't match the given $fingerprint.
+sub _fingerprint_match($$$) {
+ my ($self, $socket, $fpr) = @_;
+
+ my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256';
+ my $fpr2 = $socket->get_fingerprint($algo);
+ $fpr =~ s/.*\$//;
+ $fpr2 =~ s/.*\$//;
+ $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2;
+}
+
+
+# $self->_getline([$msg])
+# Read a line from the handle and strip the trailing CRLF.
+# /!\ Don't use this method with non-blocking IO!
+sub _getline($;$) {
+ my $self = shift;
+ my $msg = shift // '';
+
+ if ($self->{STDOUT}->opened()) {
+ my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
+ $x =~ s/\r\n\z// or $self->panic($x);
+ $self->logger("S: $msg", $x) if $self->{debug};
+ return $x;
+ }
+ else {
+ undef $self;
+ }
+}
+
+
+# $self->_update_cache( ATTRIBUTE => VALUE, [...] )
+# Update the internal cache for the currently selected mailbox with
+# the given attributes and values.
+sub _update_cache($%) {
+ my $self = shift;
+ $self->_update_cache_for($self->{_SELECTED}, @_);
+}
+
+
+# $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] )
+# Update the internal cache for $mailbox with the given attributes and
+# values.
+sub _update_cache_for($$%) {
+ my $self = shift;
+ my $mailbox = shift // $self->panic();
+ my $cache = $self->{_CACHE}->{$mailbox} //= {};
+
+ my %status = @_;
+ while (my ($k, $v) = each %status) {
+ if ($k eq 'UIDVALIDITY') {
+ # try to detect UIDVALIDITY changes early (before starting the sync)
+ $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ",
+ "Need to invalidate the UID cache.")
+ if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
+ $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v;
+ }
+ $cache->{$k} = $v;
+ }
+}
+
+
+# $self->_send($command, [$callback])
+# Send the given $command to the server, then wait for the response.
+# (The status condition and response text are respectively placed in
+# $IMAP_cond and $IMAP_text.) Each untagged response received in the
+# meantime is read, parsed and processed. The optional $callback, if
+# given, is executed with all untagged responses associated with the
+# command.
+# In void context, croak unless the server answers with a tagged 'OK'
+# response. Otherwise, return the condition status ('OK'/'NO'/'BAD').
+sub _send($$;&) {
+ my ($self, $command, $callback) = @_;
+ my $cmd = $command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $command;
+ my $set = $command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
+
+ # send the command; for servers supporting non-synchronizing
+ # literals, mark literals as such and then the whole command in one
+ # go, otherwise send literals one at a time
+ my $tag = sprintf '%06d', $self->{_TAG}++;
+ my $litplus;
+ my @command = ("$tag ");
+ my $dbg_cmd = "C: $command[0]";
+ while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
+ my ($str, $len) = ($1, $2);
+ my $lit = substr $command, 0, $len, ''; # consume the literal
+
+ $litplus //= $self->_capable('LITERAL+') ? '+' : '';
+ push @command, $str, "{$len$litplus}", "\r\n";
+ $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
+ $dbg_cmd = 'C: [...]';
+
+ unless ($litplus) {
+ $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
+ $self->{STDIN}->flush();
+ my $x = $self->_getline();
+ $x =~ /\A\+ / or $self->panic($x);
+ @command = ();
+ }
+ push @command, $lit;
+ }
+ push @command, $command, "\r\n";
+ $self->logger($dbg_cmd, $command) if $self->{debug};
+ $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
+ $self->{STDIN}->flush();
+
+
+ my $r;
+ # wait for the answer
+ while (1) {
+ my $x = $self->_getline();
+ if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) {
+ $IMAP_cond = $1;
+ $IMAP_text = $1.' '.$x;
+ $self->_resp_text($x);
+ $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK';
+ $r = $1;
+ last;
+ }
+ else {
+ $self->_resp($x, $cmd, $set, $callback);
+ }
+ }
+
+ if (defined $self->{_SELECTED}) {
+ my $mailbox = $self->{_SELECTED};
+ my $cache = $self->{_CACHE}->{$mailbox};
+ # can't keep track of the modification sequences
+ $self->fail("Mailbox $mailbox doesn't support MODSEQ.")
+ if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC');
+ $self->fail("Mailbox $mailbox does not support persistent UIDs.")
+ if defined $cache->{UIDNOTSTICKY};
+ }
+
+ return $r;
+}
+
+
+# $self->_capable($capability, [...])
+# Return true if each $capability is listed in the server's CAPABILITY
+# list.
+sub _capable($@) {
+ my $self = shift;
+ return 0 unless defined $self->{_CAPABILITIES};
+ foreach my $cap (@_) {
+ return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}};
+ }
+ return 1;
+}
+
+
+# $self->_capable($extension)
+# Return true if $extension has been enabled by the server, i.e., the
+# server sent an untagged ENABLED response including it.
+sub _enabled($$) {
+ my $self = shift;
+ my $ext = uc shift;
+ grep {$ext eq uc $_} @{$self->{_ENABLED} // []};
+}
+
+
+# $self->_open_mailbox($mailbox)
+# Initialize the internal and persistent caches for $mailbox, and mark
+# it as selected.
+sub _open_mailbox($$) {
+ my $self = shift;
+ my $mailbox = shift;
+
+ # it is safe to wipe cached VANISHED responses or FLAG updates,
+ # because interesting stuff must have made the mailbox dirty so
+ # we'll get back to it
+ $self->{_VANISHED} = [];
+ $self->{_MODIFIED} = {};
+
+ $self->{_SELECTED} = $mailbox;
+ $self->{_CACHE}->{$mailbox} //= {};
+
+ # always reset EXISTS to keep track of new mails
+ delete $self->{_CACHE}->{$mailbox}->{EXISTS};
+}
+
+
+# $self->_select_or_examine($command, $mailbox, [$seqs, $UIDs])
+# Issue a SELECT or EXAMINE command for the $mailbox. Upon success,
+# change the state to SELECTED, otherwise go back to AUTH.
+# The optional $seqs and $UIDs are used as Message Sequence Match
+# Data for the QRESYNC parameter to the $command.
+sub _select_or_examine($$$;$$) {
+ my $self = shift;
+ my $command = shift;
+ my $mailbox = shift;
+ my ($seqs, $uids) = @_;
+
+ my $pcache = $self->{_PCACHE}->{$mailbox} //= {};
+ my $cache = $self->{_CACHE}->{$mailbox} //= {};
+ $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY};
+
+ $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive
+ $command .= ' '.quote($mailbox);
+ if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) {
+ $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} "
+ ."1:".($pcache->{UIDNEXT}-1);
+ $command .= " ($seqs $uids)" if defined $seqs and defined $uids;
+ $command .= "))";
+ }
+
+ if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) {
+ # A mailbox is currently selected and the server advertises
+ # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox
+ # selection until the [CLOSED] response code has been received:
+ # all responses before the [CLOSED] response code refer to the
+ # previous mailbox ($self->{_SELECTED}), while all subsequent
+ # responses refer to the new mailbox $self->{_SELECTED_DELAYED}.
+ $self->{_SELECTED_DELAYED} = $mailbox;
+ }
+ else {
+ $self->_open_mailbox($mailbox);
+ }
+
+ $self->{_STATE} = 'AUTH';
+ $self->_send($command);
+ $self->{_STATE} = 'SELECTED';
+}
+
+
+
+#############################################################################
+# Parsing methods
+#
+
+# Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed.
+sub _resp_text($$) {
+ my $self = shift;
+ local $_ = shift;
+
+ if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) {
+ $self->log($_);
+ }
+ elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) {
+ $self->fail($_);
+ }
+ elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) {
+ $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
+ }
+ elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) {
+ $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] );
+ }
+ elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) {
+ $self->_update_cache($1 => 1);
+ }
+ elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) {
+ $self->_update_cache($1 => $2);
+ }
+ elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) {
+ # RFC 4551/7162 CONDSTORE/QRESYNC
+ $self->_update_cache(HIGHESTMODSEQ => $1);
+ }
+ elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) {
+ # RFC 4551/7162 CONDSTORE/QRESYNC
+ $self->_update_cache(NOMODSEQ => 1);
+ }
+ elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) {
+ # RFC 7162 CONDSTORE/QRESYNC
+ # Update the selected mailbox: previous responses refer to the
+ # previous mailbox ($self->{_SELECTED}), while all subsequent
+ # responses refer to the new mailbox $self->{_SELECTED_DELAYED}.
+ my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic();
+ $self->_open_mailbox($mailbox);
+ }
+ elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) {
+ # RFC 5465 NOTIFY
+ $self->fail($_);
+ }
+ elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) {
+ # RFC 4315 UIDPLUS
+ $self->_update_cache(UIDNOTSTICKY => 1);
+ }
+}
+
+# Parse and consume an RFC 3501 nstring (string / "NIL").
+sub _nstring($$) {
+ my ($self, $stream) = @_;
+ return $$stream =~ s/\ANIL// ? undef : $self->_string($stream);
+}
+
+# Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string).
+sub _astring($$) {
+ my ($self, $stream) = @_;
+ return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream);
+}
+
+# Parse and consume an RFC 3501 string (quoted / literal).
+sub _string($$) {
+ my ($self, $stream) = @_;
+ if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) {
+ # quoted
+ my $str = $1;
+ $str =~ s/\\([\x22\x5C])/$1/g;
+ return $str;
+ }
+ elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
+ # literal
+ $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
+ # read a the rest of the response
+ $$stream = $self->_getline('[...]');
+ return $lit;
+ }
+ else {
+ $self->panic($$stream);
+ }
+}
+
+# Parse and consume an RFC 3501 "(" 1*address ")" / "NIL".
+sub _addresses($$) {
+ my ($self, $stream) = @_;
+ return undef if $$stream =~ s/\ANIL//;
+
+ my @addresses;
+ $$stream =~ s/\A\(// or $self->panic($$stream);
+ while ($$stream =~ s/\A ?\(//) {
+ my @addr;
+ push @addr, $self->_nstring($stream); # addr-name
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @addr, $self->_nstring($stream); # addr-adl
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @addr, $self->_nstring($stream); # addr-mailbox
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @addr, $self->_nstring($stream); # addr-host
+ $$stream =~ s/\A\)// or $self->panic($$stream);
+ push @addresses, \@addr;
+ }
+ $$stream =~ s/\A\)// or $self->panic($$stream);
+ return \@addresses;
+}
+
+# Parse and consume an RFC 3501 envelope
+sub _envelope($$) {
+ my ($self, $stream) = @_;
+ $$stream =~ s/\A\(// or $self->panic($$stream);
+
+ my @envelope;
+ push @envelope, $self->_nstring($stream); # env-date
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_nstring($stream); # env-subject
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-from
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-sender
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-reply-to
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-to
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-cc
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-bcc
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_nstring($stream); # env-in-reply-to
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_nstring($stream); # env-message-id
+
+ $$stream =~ s/\A\)// or $self->panic($$stream);
+ return \@envelope;
+}
+
+# $self->_resp($buf, [$cmd, $callback] )
+# Parse an untagged response line or a continuation request line.
+# (The trailing CRLF must be removed.) The internal cache is
+# automatically updated when needed.
+# If a command and callback are given, the callback is be executed
+# for each (parsed) responses associated with the command.
+sub _resp($$;$$$) {
+ my $self = shift;
+ local $_ = shift;
+ my $cmd = shift;
+ my $set = shift;
+ my $callback = shift;
+ my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED};
+
+ if (s/\A\* //) {
+ if (s/\ABYE //) {
+ undef $self;
+ }
+ elsif (s/\A(?:OK|NO|BAD) //) {
+ $self->_resp_text($_);
+ }
+ elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) {
+ $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
+ }
+ elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) {
+ $cache->{FLAGS} = [ split / /, $1 ];
+ }
+ elsif (/\A([0-9]+) RECENT\z/) {
+ $cache->{RECENT} = $1;
+ }
+ elsif (/\A([0-9]+) EXISTS\z/) {
+ # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT
+ if (defined $cache->{EXISTS}) {
+ $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS};
+ # the actual UIDNEXT is *at least* that
+ $cache->{UIDNEXT} += $1 - $cache->{EXISTS} if defined $cache->{UIDNEXT};
+ }
+ $cache->{EXISTS} = $1;
+ }
+ elsif (/\A([0-9]+) EXPUNGE\z/) {
+ # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
+ $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check
+ $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC');
+ $cache->{EXISTS}--; # explicit EXISTS responses are optional
+ }
+ elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
+ $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
+ }
+ 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);
+ my @attrs = defined $attrs ? split(/ /, $attrs) : ();
+ my $mailbox = $self->_astring(\$_);
+ $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;
+ $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';
+ }
+ elsif (s/\ASTATUS //) {
+ my $mailbox = $self->_astring(\$_);
+ /\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->_update_cache_for($mailbox, %status);
+ $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS';
+ }
+ elsif (s/\A([0-9]+) FETCH \(//) {
+ $self->panic("$1 <= $cache->{EXISTS}") unless $1 <= $cache->{EXISTS}; # sanity check
+ my ($seq, $first) = ($1, 1);
+ my %mail;
+ while ($_ ne ')') {
+ unless (defined $first) {
+ s/\A // or $self->panic($_);
+ }
+ if (s/\AUID ([0-9]+)//) {
+ # always present, cf RFC 3501 section 6.4.8
+ $mail{UID} = $1;
+ # the actual UIDNEXT is *at least* that
+ $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} <= $1;
+ }
+ if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC
+ # always present in unsolicited FETCH responses if QRESYNC has been enabled
+ $mail{MODSEQ} = $1;
+ $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1;
+ }
+ elsif (s/\AENVELOPE //) {
+ $mail{ENVELOPE} = $self->_envelope(\$_);
+ }
+ elsif (s/\AINTERNALDATE "([^"]+)"//) {
+ $mail{INTERNALDATE} = $1;
+ }
+ elsif (s/\A(?:RFC822|BODY\[\]) //) {
+ $mail{RFC822} = $self->_nstring(\$_);
+ }
+ elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
+ $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : [];
+ }
+ undef $first;
+ }
+
+ my $uid = $mail{UID} // $self->panic(); # sanity check
+ $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
+
+ if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
+ (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or
+ ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) {
+ my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS};
+ $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ];
+ }
+ $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set);
+ }
+ elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE
+ $self->{_ENABLED} //= [];
+ push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r));
+ }
+ elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC
+ my $earlier = defined $1 ? 1 : 0;
+ my $set = $2;
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+ my $pcache = $self->{_PCACHE}->{$mailbox};
+ foreach (split /,/, $set) {
+ if (/\A([0-9]+)\z/) {
+ $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional
+ $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that
+ push @{$self->{_VANISHED}}, $1;
+ }
+ elsif (/\A([0-9]+):([0-9]+)\z/) {
+ my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
+ $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional
+ $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that
+ push @{$self->{_VANISHED}}, ($min .. $max);
+ }
+ }
+ }
+ }
+ elsif (s/\A\+ //) {
+ if (defined $callback and $cmd eq 'AUTHENTICATE') {
+ my $x = $callback->($_);
+ $self->logger("C: ", $x) if $self->{debug};
+ $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
+ $self->{STDIN}->flush();
+ }
+ }
+ else {
+ $self->panic("Unexpected response: ", $_);
+ }
+}
+
+
+#############################################################################
+
+return 1;
+++ /dev/null
-#----------------------------------------------------------------------
-# A minimal IMAP4 client for QRESYNC-capable servers
-# Copyright © 2015 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
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>.
-#----------------------------------------------------------------------
-
-package Net::IMAP::Sync v0.0.1;
-use warnings;
-use strict;
-
-use Config::Tiny ();
-use IO::Select ();
-use List::Util 'first';
-use Socket 'SO_KEEPALIVE';
-
-use Exporter 'import';
-BEGIN {
- our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/;
-}
-
-
-# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'.
-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]/;
-
-# Map each option to a regexp validating its values.
-my %OPTIONS = (
- host => qr/\A([0-9a-zA-Z:.-]+)\z/,
- port => qr/\A([0-9]+)\z/,
- type => qr/\A(imaps?|tunnel)\z/,
- STARTTLS => qr/\A(YES|NO)\z/i,
- username => qr/\A([\x01-\x7F]+)\z/,
- password => qr/\A([\x01-\x7F]+)\z/,
- auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
- command => qr/\A(\/\P{Control}+)\z/,
- SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
- SSL_cipher_list => qr/\A(\P{Control}+)\z/,
- SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
- SSL_ca_path => qr/\A(\P{Control}+)\z/,
-);
-
-
-#############################################################################
-# Utilities
-
-# read_config($conffile, $sections, %opts)
-# Read $conffile's default section, then each section in the array
-# reference $section (which takes precedence). %opts extends %OPTIONS
-# and maps each option to a regexp validating its values.
-sub read_config($$%) {
- my $conffile = shift;
- 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;
-
- my $h = Config::Tiny::->read($conffile);
-
- my %configs;
- foreach my $section (@$sections) {
- my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section
- $configs{$section} = $conf;
-
- if ($section ne '_') {
- die "No such section $section\n" unless defined $h->{$section};
- $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
- }
-
- # default values
- $conf->{type} //= 'imaps';
- $conf->{host} //= 'localhost';
- $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef;
- $conf->{auth} //= 'PLAIN LOGIN';
- $conf->{STARTTLS} //= 'YES';
-
- # untaint and validate the config
- foreach my $k (keys %$conf) {
- die "Invalid option $k\n" unless defined $opts{$k};
- next unless defined $conf->{$k};
- die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
- $conf->{$k} = $1;
- }
- }
- return \%configs;
-}
-
-
-# compact_set(@set).
-# Compact the UID or sequence number set @set, which must be
-# non-empty and may not contain '*'. (Duplicates are allowed, but
-# are removed).
-sub compact_set(@) {
- my @set = sort {$a <=> $b} @_;
- my $min = my $max = shift @set // die 'Empty range';
- my $set;
-
- while (@set) {
- my $k = shift @set;
- if ($k < $max) {
- die "Non-sorted range: $k < $max"; # sanity check
- }
- elsif ($k == $max) { # skip duplicates
- }
- elsif ($k == $max + 1) {
- $max++;
- }
- else {
- $set .= ',' if defined $set;
- $set .= $min == $max ? $min : "$min:$max";
- $min = $max = $k;
- }
- }
-
- $set .= ',' if defined $set;
- $set .= $min == $max ? $min : "$min:$max";
- return $set;
-}
-
-
-# in_set($x, $set)
-# Return true if the UID or sequence number $x belongs to the set $set.
-# /!\ The highest number in the mailbox, "*" should not appear by
-# itself (other than in a range).
-sub in_set($$) {
- my ($x, $set) = @_;
- foreach my $r (split /,/, $set) {
- if ($r =~ /\A([0-9]+)\z/) {
- return 1 if $x == $1;
- }
- elsif ($r eq '*' or $r eq '*:*') {
- warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
- return 1;
- }
- elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) {
- return 1 if $1 <= $x;
- }
- elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) {
- my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1);
- return 1 if $min <= $x and $x <= $max;
- }
- }
- return 0;
-}
-
-
-# quote($str)
-# Quote the given string if needed, or make it a (synchronizing)
-# literal. The literals will later be made non-synchronizing if the
-# server is LITERAL+-capable (RFC 2088).
-sub quote($) {
- my $str = shift;
- if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) {
- return $str;
- }
- elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) {
- $str =~ s/([\x22\x5C])/\\$1/g;
- return "\"$str\"";
- }
- else {
- return "{".length($str)."}\r\n".$str;
- }
-}
-
-
-
-#############################################################################
-# Public interface
-# /!\ While this module can be used with non QRESYNC-capable (or non
-# QRESYNC-enabled) servers, there is no internal cache mapping sequence
-# numbers to UIDs, so EXPUNGE responses are ignored.
-
-# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status
-# ('OK'/'NO'/'BAD') condition for the last command issued.
-our $IMAP_cond;
-
-# The response text for the last command issued (prefixed with the status
-# condition but without the tag).
-our $IMAP_text;
-
-
-# Create a new Net::IMAP::Sync object. Connect to the server,
-# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and
-# update the CAPABILITY list.
-# In addition to the %OPTIONS above, valid parameters include:
-#
-# - 'debug': Enable debug messages.
-#
-# - 'enable': An extension or array reference of extensions to ENABLE
-# (RFC 5161) after entering AUTH state. Croak if the server did not
-# advertise "ENABLE" in its CAPABILITY list or does not reply with
-# an untagged ENABLED response with all the given extensions.
-#
-# - 'name': An optional instance name to include in log messages.
-#
-# - 'extra-attrs': An attribute or list of extra attributes to FETCH
-# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
-# BODY.PEEK[]).
-#
-# - 'logger-fd': An optional filehandle to use for debug output.
-#
-sub new($%) {
- my $class = shift;
- my $self = { @_ };
- bless $self, $class;
-
- # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
- # (cf RFC 3501 section 3)
- $self->{_STATE} = '';
-
- if ($self->{type} eq 'tunnel') {
- require 'IPC/Open2.pm';
- my $command = $self->{command} // $self->fail("Missing tunnel command");
- my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, $command)
- or $self->panic("Can't fork: $!");
- }
- else {
- my %args = (Proto => 'tcp', Blocking => 1);
- $args{PeerHost} = $self->{host} // $self->fail("Missing option host");
- $args{PeerPort} = $self->{port} // $self->fail("Missing option port");
-
- my $socket;
- if ($self->{type} eq 'imap') {
- require 'IO/Socket/INET.pm';
- $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
- }
- else {
- require 'IO/Socket/SSL.pm';
- if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) {
- $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO';
- }
- my $fpr = delete $self->{SSL_fingerprint};
- $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
- $socket = IO::Socket::SSL->new(%args)
- or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
-
- # ensure we're talking to the right server
- $self->_fingerprint_match($socket, $fpr) if defined $fpr;
- }
-
- $socket->sockopt(SO_KEEPALIVE, 1);
- $self->{$_} = $socket for qw/STDOUT STDIN/;
- }
- $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!");
-
- # command counter
- $self->{_TAG} = 0;
-
- # internal cache, constantly updated to reflect the current server
- # state for each mailbox
- $self->{_CACHE} = {};
-
- # persistent cache, describing the last clean (synced) state
- $self->{_PCACHE} = {};
-
- # list of UIDs for which the server a VANISHED or VANISHED (EARLIER)
- # response. /!\ requires a QRESYNC-capable server!
- # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
- # are considered.
- $self->{_VANISHED} = [];
-
- # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH
- # response with the FLAGS attribute. The \Recent flag is always
- # omitted from the FLAG list. MODSEQ is always present, and the
- # value [ MODSEQ, FLAGS ] is updated if another FETCH response with
- # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG
- # list of the message is considered unknown and should be retrieved
- # manually.
- # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
- # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ}
- # are considered.
- $self->{_MODIFIED} = {};
-
- if (defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR) {
- require 'POSIX.pm';
- require 'Time/HiRes.pm';
- }
-
- # wait for the greeting
- my $x = $self->_getline();
- $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x);
- $IMAP_cond = $1;
- $IMAP_text = $1.' '.$x;
-
- # try to update the cache (eg, capabilities)
- $self->_resp_text($x);
-
- if ($IMAP_cond eq 'OK') {
- # login required
- $self->{_STATE} = 'UNAUTH';
- my @caps = $self->capabilities();
-
- if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1
- $self->fail("Server did not advertise STARTTLS capability.")
- unless grep {$_ eq 'STARTTLS'} @caps;
-
- require 'IO/Socket/SSL.pm';
- $self->_send('STARTTLS');
-
- my %sslargs;
- if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) {
- $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO';
- }
- my $fpr = delete $self->{SSL_fingerprint};
- $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
- IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs)
- or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
-
- # ensure we're talking to the right server
- $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr;
-
- # refresh the previous CAPABILITY list since the previous one could have been spoofed
- delete $self->{_CAPABILITIES};
- @caps = $self->capabilities();
- }
-
- my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps);
- my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef}
- split(/ /, $self->{auth}))[0];
- $self->fail("Failed to choose an authentication mechanism") unless defined $mech;
- $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and
- grep {$_ eq 'LOGINDISABLED'} @caps;
-
- my ($command, $callback);
- my ($username, $password) = @$self{qw/username password/};
-
- if ($mech eq 'LOGIN') {
- $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
- $command = join ' ', 'LOGIN', quote($username), quote($password);
- }
- elsif ($mech eq 'PLAIN') {
- require 'MIME/Base64.pm';
- $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
- my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, '');
- $command = "AUTHENTICATE $mech";
- if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR
- $command .= " $credentials";
- } else {
- $callback = sub($) {return $credentials};
- }
- }
- else {
- $self->fail("Unsupported authentication mechanism: $mech");
- }
-
- delete $self->{password}; # no need to remember passwords
- $self->_send($command, $callback);
- unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) {
- # refresh the CAPABILITY list since the previous one had only pre-login capabilities
- delete $self->{_CAPABILITIES};
- $self->capabilities();
- }
- }
-
- $self->{_STATE} = 'AUTH';
- my @extensions = !defined $self->{enable} ? ()
- : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}}
- : ($self->{enable});
- if (@extensions) {
- $self->fail("Server did not advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE');
- $self->_send('ENABLE '.join(' ',@extensions));
- my @enabled = @{$self->{_ENABLED} // []};
- $self->fail("Couldn't ENABLE $_") foreach
- grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions;
- }
-
- return $self;
-}
-
-
-# Log out when the Net::IMAP::Sync object is destroyed.
-sub DESTROY($) {
- my $self = shift;
- foreach (qw/STDIN STDOUT/) {
- $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
- }
-}
-
-
-# $self->log($message, [...])
-# $self->logger($message, [...])
-# Log a $message. The latter method is used to log in the 'logger-fd', and
-# add timestamps.
-sub log($@) {
- my $self = shift;
- return unless @_;
- $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR;
- my $prefix = defined $self->{name} ? $self->{name} : '';
- $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
- print STDERR $prefix, ': ', @_, "\n";
-}
-sub logger($@) {
- my $self = shift;
- return unless @_ and defined $self->{'logger-fd'};
- my $prefix = '';
- if ($self->{'logger-fd'}->fileno != fileno STDERR) {
- my ($s, $us) = Time::HiRes::gettimeofday();
- $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us ";
- }
- $prefix .= defined "$self->{name}" ? $self->{name} : '';
- $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
- $self->{'logger-fd'}->say($prefix, ': ', @_);
-}
-
-
-# $self->warn($warning, [...])
-# Log a $warning.
-sub warn($$@) {
- my $self = shift;
- $self->log('WARNING: ', @_);
-}
-
-
-# $self->fail($error, [...])
-# Log an $error and exit with return value 1.
-sub fail($$@) {
- my $self = shift;
- $self->log('ERROR: ', @_);
- exit 1;
-}
-
-
-# $self->panic($error, [...])
-# Log a fatal $error including the position of the caller, and exit
-# with return value 255.
-sub panic($@) {
- my $self = shift;
- my @loc = caller;
- my $msg = "PANIC at line $loc[2] in $loc[1]";
- $msg .= ': ' if @_;
- $self->log($msg, @_);
- exit 255;
-}
-
-
-# $self->capabilities()
-# Return the capability list of the IMAP4 server. The list is cached,
-# and a CAPABILITY command is only issued if the cache is empty.
-sub capabilities($) {
- my $self = shift;
- $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}};
- $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1');
- return @{$self->{_CAPABILITIES}};
-}
-
-
-# $self->incapable(@capabilities)
-# In list context, return the list capabilties from @capabilities
-# which were NOT advertised by the server. In scalar context, return
-# the length of said list.
-sub incapable($@) {
- my ($self, @caps) = @_;
- my @mycaps = $self->capabilities();
- grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps;
-}
-
-
-# $self->search($criterion)
-# Issue an UID SEARCH command with the given $criterion. Return the
-# list of matching UIDs.
-sub search($$) {
- my ($self, $crit) = @_;
- my @res;
- $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_});
- return @res
-}
-
-
-# $self->select($mailbox, [$seqs, $UIDs])
-# $self->examine($mailbox, [$seqs, $UIDs])
-# Issue a SELECT or EXAMINE command for the $mailbox. Upon success,
-# change the state to SELECTED, otherwise go back to AUTH.
-# The optional $seqs and $UIDs are used as Message Sequence Match
-# Data for the QRESYNC parameter to the SELECT command.
-sub select($$;$$) {
- my $self = shift;
- my $mailbox = shift;
- $self->_select_or_examine('SELECT', $mailbox, @_);
-}
-sub examine($$;$$) {
- my $self = shift;
- my $mailbox = shift;
- $self->_select_or_examine('EXAMINE', $mailbox, @_);
-}
-
-
-# $self->logout()
-# Issue a LOGOUT command. Change the state to LOGOUT.
-sub logout($) {
- my $self = shift;
- # don't bother if the connection is already closed
- $self->_send('LOGOUT') if $self->{STDIN}->opened();
- $self->{_STATE} = 'LOGOUT';
- undef $self;
-}
-
-
-# $self->noop()
-# Issue a NOOP command.
-sub noop($) {
- shift->_send('NOOP');
-}
-
-
-# $self->create($mailbox, [$try])
-# $self->delete($mailbox, [$try])
-# CREATE or DELETE $mailbox.
-# If try is set, print a warning but don't crash if the command fails.
-sub create($$;$) {
- my ($self, $mailbox, $try) = @_;
- my $r = $self->_send("CREATE ".quote($mailbox));
- if ($IMAP_cond eq 'OK') {
- $self->log("Created mailbox ".$mailbox) unless $self->{quiet};
- }
- else {
- my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text;
- $try ? $self->warn($msg) : $self->fail($msg);
- }
- return $r;
-}
-sub delete($$;$) {
- my ($self, $mailbox, $try) = @_;
- my $r = $self->_send("DELETE ".quote($mailbox));
- delete $self->{_CACHE}->{$mailbox};
- delete $self->{_PCACHE}->{$mailbox};
- if ($IMAP_cond eq 'OK') {
- $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet};
- }
- else {
- my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text;
- $try ? $self->warn($msg) : $self->fail($msg);
- }
- return $r;
-}
-
-
-# $self->rename($oldname, $newname, [$try])
-# RENAME the mailbox $oldname to $newname.
-# If $try is set, print a warning but don't crash if the command fails.
-# /!\ Requires a LIST command to be issued to determine the hierarchy
-# delimiter and the mailbox attributes for the original name.
-sub rename($$$;$) {
- my ($self, $from, $to, $try) = @_;
- my ($delim, @attrs);
- if ($self->{_CACHE}->{$from}) {
- $delim = $self->{_CACHE}->{$from}->{DELIMITER};
- @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []};
- }
- my $r = $self->_send("RENAME ".quote($from).' '.quote($to));
- $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from};
- $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from};
- if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) {
- # on non-flat mailboxes, move children as well (cf 3501)
- foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) {
- my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r;
- $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1};
- $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1};
- }
- }
- if ($IMAP_cond eq 'OK') {
- $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet};
- }
- else {
- my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text;
- $try ? $self->warn($msg) : $self->fail($msg);
- }
- return $r;
-}
-
-
-# $self->subscribe($mailbox, [$try])
-# $self->unsubscribe($mailbox, [$try])
-# SUBSCRIBE or UNSUBSCRIBE $mailbox.
-# If $try is set, print a warning but don't crash if the command fails.
-sub subscribe($$;$) {
- my ($self, $mailbox, $try) = @_;
- my $r = $self->_send("SUBSCRIBE ".quote($mailbox));
- if ($IMAP_cond eq 'OK') {
- $self->log("Subscribe to ".$mailbox) unless $self->{quiet};
- }
- else {
- my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text;
- $try ? $self->warn($msg) : $self->fail($msg);
- }
- return $r;
-}
-sub unsubscribe($$;$) {
- my ($self, $mailbox, $try) = @_;
- my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox));
- if ($IMAP_cond eq 'OK') {
- $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet};
- }
- else {
- my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text;
- $try ? $self->warn($msg) : $self->fail($msg);
- }
- return $r;
-}
-
-
-# $self->list($criterion, @parameters)
-# Issue a LIST command with the given $criterion and @parameters.
-# Return a pair where the first component is a hash reference of
-# matching mailboxes and their flags, and the second component is a
-# hash reference of matching mailboxes and their hierarchy delimiter
-# (or undef for flat mailboxes).
-sub list($$@) {
- my $self = shift;
- my $crit = shift;
- my %mailboxes;
- my %delims;
- $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''),
- sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} );
- return (\%mailboxes, \%delims);
-}
-
-
-# $self->remove_message($uid, [...])
-# Remove the given $uid list. Croak if the server did not advertise
-# "UIDPLUS" (RFC 4315) in its CAPABILITY list.
-# Successfully EXPUNGEd UIDs are removed from the pending VANISHED and
-# MODIFIED lists.
-# Return the list of UIDs that couldn't be EXPUNGEd.
-sub remove_message($@) {
- my $self = shift;
- my @set = @_;
- $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
- if $self->incapable('UIDPLUS');
-
- my $set = compact_set(@set);
- $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
- $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS
-
- my %vanished = map {$_ => 1} @{$self->{_VANISHED}};
-
- my (@failed, @expunged);
- foreach my $uid (@set) {
- if (exists $vanished{$uid}) {
- push @expunged, $uid
- } else {
- push @failed, $uid;
- }
- }
-
- # ignore succesfully EXPUNGEd messages
- delete @vanished{@expunged};
- delete @{$self->{_MODIFIED}}{@expunged};
- $self->{_VANISHED} = [ keys %vanished ];
-
- $self->log("Removed ".($#expunged+1)." message(s), ".
- "UID ".compact_set(@expunged)) if @expunged and !$self->{quiet};
- $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed;
- return @failed;
-}
-
-
-# $self->append($mailbox, $mail, [...])
-# Issue an APPEND command with the given mails. Croak if the server
-# did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list.
-# Providing multiple mails is only allowed for servers advertising
-# "MULTIAPPEND" (RFC 3502) in their CAPABILITY list.
-# Return the list of UIDs allocated for the new messages.
-sub append($$@) {
- my $self = shift;
- my $mailbox = shift;
- return unless @_;
- $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
- if $self->incapable('UIDPLUS');
-
- my @appends;
- foreach my $mail (@_) {
- my $append = '';
- $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') '
- if defined $mail->{FLAGS};
- $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
- $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822};
- push @appends, $append;
- }
- $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.")
- if $#appends > 0 and $self->incapable('MULTIAPPEND');
-
- # dump the cache before issuing the command if we're appending to the current mailbox
- my ($UIDNEXT, $EXISTS, $cache, %vanished);
- if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
- $cache = $self->{_CACHE}->{$mailbox};
- $UIDNEXT = $cache->{UIDNEXT} // $self->panic();
- $EXISTS = $cache->{EXISTS} // $self->panic();
- %vanished = map {$_ => 1} @{$self->{_VANISHED}};
- }
-
- $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends));
- $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text);
- my ($uidvalidity, $uidset) = ($1, $2);
- $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity);
-
- my @uids;
- foreach (split /,/, $uidset) {
- if (/\A([0-9]+)\z/) {
- $UIDNEXT = $1 + 1 if defined $UIDNEXT and $UIDNEXT <= $1;
- push @uids, $1;
- } elsif (/\A([0-9]+):([0-9]+)\z/) {
- my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1);
- push @uids, ($min .. $max);
- $UIDNEXT = $max + 1 if defined $UIDNEXT and $UIDNEXT <= $max;
- } else {
- $self->panic($_);
- }
- }
- $self->fail("$uidset contains ".scalar(@uids)." elements while "
- .scalar(@appends)." messages were appended.")
- unless $#uids == $#appends;
-
- # if $mailbox is the current mailbox we need to update the cache
- if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
- # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required
- my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}};
- delete $vanished2{$_} foreach keys %vanished;
- my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile
- $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS;
- $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT;
- }
-
- $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids))
- unless $self->{quiet};
- return @uids;
-}
-
-
-# $self->fetch($set, $flags, [$callback])
-# Issue an UID FETCH command with the given UID $set, $flags, and
-# optional $callback.
-sub fetch($$$$) {
- my ($self, $set, $flags, $callback) = @_;
- $self->_send("UID FETCH $set $flags", $callback);
-}
-
-
-# $self->notify(@specifications)
-# Issue a NOTIFY command with the given mailbox @specifications (cf RFC
-# 5465 section 6) to be monitored. Croak if the server did not
-# advertise "NOTIFY" (RFC 5465) in its CAPABILITY list.
-sub notify($@) {
- my $self = shift;
- $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.")
- if $self->incapable('NOTIFY');
- my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/;
- # Be notified of new messages with EXISTS/RECENT responses, but
- # don't receive unsolicited FETCH responses with a RFC822/BODY[].
- # It costs us an extra roundtrip, but we need to sync FLAG updates
- # and VANISHED responses in batch mode, update the HIGHESTMODSEQ,
- # and *then* issue an explicit UID FETCH command to get new message,
- # and process each FETCH response with a RFC822/BODY[] attribute as
- # they arrive.
- my $command = 'NOTIFY ';
- $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
- $self->_send($command);
- $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT});
-}
-
-
-# $self->slurp()
-# See if the server has sent some unprocessed data; try to as many
-# lines as possible, process them, and return the number of lines
-# read.
-# This is mostly useful when waiting for notifications while no
-# command is progress, cf. RFC 5465 (NOTIFY).
-sub slurp($) {
- my $self = shift;
-
- my $stdout = $self->{STDOUT};
- my $read = 0;
-
- while (1) {
- # Unprocessed data within the current SSL frame would cause
- # select(2) to block/timeout due to the raw socket not being
- # ready.
- unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) {
- my ($ok) = $self->{_SEL_OUT}->can_read(0);
- return $read unless defined $ok;
- }
-
- $self->_resp( $self->_getline() );
- $read++;
- }
-}
-
-
-# $self->set_cache( $mailbox, STATE )
-# Initialize or update the persistent cache, that is, associate a
-# known $mailbox with the last known (synced) state:
-# * UIDVALIDITY
-# * UIDNEXT: Any message the UID of which is at least UIDNEXT is
-# considered new and must be downloaded. (If 0 or missing, all
-# messages in $mailbox are considered new.) Note that while all
-# UIDs in the map are <UIDNEXT, the message with UID UIDNEXT-1 may
-# have been deleted hence may no longer be present in $mailbox.
-# * HIGHESTMODSEQ: Any change with MODSEQ <= HIGHESTMODSEQ have been
-# processed. (Note however that new messages may have a lower
-# MODSEQ.) Always present when UIDNEXT is present.
-sub set_cache($$%) {
- my $self = shift;
- my $mailbox = shift // $self->panic();
- my $cache = $self->{_PCACHE}->{$mailbox} //= {};
-
- my %status = @_;
- while (my ($k, $v) = each %status) {
- if ($k eq 'UIDVALIDITY') {
- # try to detect UIDVALIDITY changes early (before starting the sync)
- $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ",
- "Need to invalidate the UID cache.")
- if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
- }
- $cache->{$k} = $v;
- }
-
- $self->logger("Update last clean state for $mailbox: ".
- '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')')
- if $self->{debug};
-}
-
-
-# $self->uidvalidity([$mailbox])
-# Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to
-# its UIDVALIDITY if $mailbox is omitted.
-sub uidvalidity($;$) {
- my $self = shift;
- my $mailbox = shift;
- if (defined $mailbox) {
- my $cache = $self->{_CACHE}->{$mailbox} // return;
- return $cache->{UIDVALIDITY};
- }
- else {
- my %uidvalidity;
- while (my ($mbx,$cache) = each %{$self->{_CACHE}}) {
- $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0;
- }
- return %uidvalidity;
- }
-}
-
-
-# $self->set_cache(@attributes)
-# Return the persistent cache for the mailbox currently selected. If
-# some @attributes are given, return the list of values corresponding
-# to these attributes.
-# /!\ Should only be called right after pull_updates!
-# Croak if there are unprocessed VANISHED responses or FLAG updates.
-sub get_cache($@) {
- my $self = shift;
- $self->fail("Invalid method 'get_cache' in state $self->{_STATE}")
- unless $self->{_STATE} eq 'SELECTED';
- my $mailbox = $self->{_SELECTED} // $self->panic();
-
- $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}};
- $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}};
-
- my $cache = $self->{_PCACHE}->{$mailbox};
- return @_ ? @$cache{@_} : %$cache;
-}
-
-
-# $self->is_dirty($mailbox)
-# Return true if there are pending updates for $mailbox, i.e., its
-# internal cache is newer than its persistent cache.
-sub is_dirty($$) {
- my ($self, $mailbox) = @_;
- my $cache = $self->{_CACHE}->{$mailbox} // return 1;
- my $pcache = $self->{_PCACHE}->{$mailbox} // return 1;
-
- if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ}
- and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and
- defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT}
- and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) {
- return 0
- } else {
- return 1
- }
-}
-
-
-# $self->next_dirty_mailbox(@mailboxes)
-# Return the name of a dirty mailbox, or undef if all mailboxes are
-# clean. If @mailbox is non-empty, only consider mailboxes in that
-# list.
-sub next_dirty_mailbox($@) {
- my $self = shift;
- my %mailboxes = map {$_ => 1} @_;
- my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) }
- keys %{$self->{_CACHE}};
- if ($self->{debug}) {
- @dirty ? $self->logger("Dirty mailboxes: ".join(', ', @dirty))
- : $self->logger("Clean state!");
- }
- return $dirty[0];
-}
-
-
-# $self->pull_updates([$full])
-# If $full is set, FETCH FLAGS and MODSEQ for each UID up to
-# UIDNEXT-1.
-# Get pending updates (unprocessed VANISHED responses and FLAG
-# updates), and empty these lists from the cache.
-# Finally, update the HIGHESTMODSEQ from the persistent cache to the
-# value found in the internal cache.
-sub pull_updates($;$) {
- my $self = shift;
- my $full = shift // 0;
- 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;
- while (%{$self->{_MODIFIED}}) {
- 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
- 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
- $modified{$uid} = $full ? $v : $v->[1];
- } else {
- push @missing, $uid;
- }
- }
- $self->{_MODIFIED} = {};
- $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
- my %vanished = map {$_ => 1} grep { $_ < ($pcache->{UIDNEXT} // 1) } @{$self->{_VANISHED}};
- my @vanished = keys %vanished;
- $self->{_VANISHED} = [];
-
- # ignore FLAG updates on VANISHED messages
- delete @modified{@vanished};
-
- # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT
- # since there might be new messages)
- $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ});
-
- return (\@vanished, \%modified);
-}
-
-
-# $self->pull_new_messages($callback, @ignore)
-# FETCH new messages since the UIDNEXT found in the persistent cache
-# (or 1 in no such UIDNEXT is found), and process each response on the
-# fly with the callback.
-# If an @ignore list is supplied, then these messages are ignored from
-# the UID FETCH range.
-# Finally, update the UIDNEXT from the persistent cache to the value
-# found in the internal cache.
-# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ!
-sub pull_new_messages($$@) {
- my $self = shift;
- my $callback = shift;
- my @ignore = sort { $a <=> $b } @_;
- my @attrs = !defined $self->{'extra-attrs'} ? ()
- : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}}
- : ($self->{'extra-attrs'});
- my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]';
-
- my $mailbox = $self->{_SELECTED} // $self->panic();
-
- my $UIDNEXT;
- do {
- my $range = '';
- my $first;
- my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1;
- foreach my $uid (@ignore) {
- if ($since < $uid) {
- $first //= $since;
- $range .= ',' if $range ne '';
- $range .= $since;
- $range .= ':'.($uid-1) if $since < $uid-1;
- $since = $uid+1;
- }
- elsif ($since == $uid) {
- $since++;
- }
- }
-
- $first //= $since;
- $range .= ',' if $range ne '';
- # 2^32-1: don't use '*' since the highest UID can be known already
- $range .= "$since:4294967295";
-
- $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT} // $self->panic(); # sanity check
- $self->_send("UID FETCH $range ($attrs)", sub($) {
- my $mail = shift;
- $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID};
- $callback->($mail) if defined $callback;
- }) if $first < $UIDNEXT;
-
- # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ
- # since there might be pending updates)
- $self->set_cache($mailbox, UIDNEXT => $UIDNEXT);
- }
- # loop if new messages were received in the meantime
- while ($UIDNEXT < $self->{_CACHE}->{$mailbox}->{UIDNEXT});
-}
-
-
-# $self->push_flag_updates($flags, @set)
-# Change the flags to each UID in @set to $flags.
-# A flag update fails for mails being updated after the HIGHESTMODSEQ
-# found in the persistent cache; push such messages to the MODIFIED
-# list.
-sub push_flag_updates($$@) {
- my $self = shift;
- my $flags = shift;
- my @set = @_;
-
- 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 %failed;
- 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) {
- 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};
- }
- 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;
- }
- return keys %failed;
-}
-
-
-#############################################################################
-# Private methods
-
-
-# $self->_fingerprint_match($socket, $fingerprint)
-# Croak unless the fingerprint of the peer certificate of the
-# IO::Socket::SSL object doesn't match the given $fingerprint.
-sub _fingerprint_match($$$) {
- my ($self, $socket, $fpr) = @_;
-
- my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256';
- my $fpr2 = $socket->get_fingerprint($algo);
- $fpr =~ s/.*\$//;
- $fpr2 =~ s/.*\$//;
- $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2;
-}
-
-
-# $self->_getline([$msg])
-# Read a line from the handle and strip the trailing CRLF.
-# /!\ Don't use this method with non-blocking IO!
-sub _getline($;$) {
- my $self = shift;
- my $msg = shift // '';
-
- if ($self->{STDOUT}->opened()) {
- my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
- $x =~ s/\r\n\z// or $self->panic($x);
- $self->logger("S: $msg", $x) if $self->{debug};
- return $x;
- }
- else {
- undef $self;
- }
-}
-
-
-# $self->_update_cache( ATTRIBUTE => VALUE, [...] )
-# Update the internal cache for the currently selected mailbox with
-# the given attributes and values.
-sub _update_cache($%) {
- my $self = shift;
- $self->_update_cache_for($self->{_SELECTED}, @_);
-}
-
-
-# $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] )
-# Update the internal cache for $mailbox with the given attributes and
-# values.
-sub _update_cache_for($$%) {
- my $self = shift;
- my $mailbox = shift // $self->panic();
- my $cache = $self->{_CACHE}->{$mailbox} //= {};
-
- my %status = @_;
- while (my ($k, $v) = each %status) {
- if ($k eq 'UIDVALIDITY') {
- # try to detect UIDVALIDITY changes early (before starting the sync)
- $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ",
- "Need to invalidate the UID cache.")
- if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
- $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v;
- }
- $cache->{$k} = $v;
- }
-}
-
-
-# $self->_send($command, [$callback])
-# Send the given $command to the server, then wait for the response.
-# (The status condition and response text are respectively placed in
-# $IMAP_cond and $IMAP_text.) Each untagged response received in the
-# meantime is read, parsed and processed. The optional $callback, if
-# given, is executed with all untagged responses associated with the
-# command.
-# In void context, croak unless the server answers with a tagged 'OK'
-# response. Otherwise, return the condition status ('OK'/'NO'/'BAD').
-sub _send($$;&) {
- my ($self, $command, $callback) = @_;
- my $cmd = $command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $command;
- my $set = $command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
-
- # send the command; for servers supporting non-synchronizing
- # literals, mark literals as such and then the whole command in one
- # go, otherwise send literals one at a time
- my $tag = sprintf '%06d', $self->{_TAG}++;
- my $litplus;
- my @command = ("$tag ");
- my $dbg_cmd = "C: $command[0]";
- while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
- my ($str, $len) = ($1, $2);
- my $lit = substr $command, 0, $len, ''; # consume the literal
-
- $litplus //= $self->_capable('LITERAL+') ? '+' : '';
- push @command, $str, "{$len$litplus}", "\r\n";
- $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
- $dbg_cmd = 'C: [...]';
-
- unless ($litplus) {
- $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
- my $x = $self->_getline();
- $x =~ /\A\+ / or $self->panic($x);
- @command = ();
- }
- push @command, $lit;
- }
- push @command, $command, "\r\n";
- $self->logger($dbg_cmd, $command) if $self->{debug};
- $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
-
-
- my $r;
- # wait for the answer
- while (1) {
- my $x = $self->_getline();
- if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) {
- $IMAP_cond = $1;
- $IMAP_text = $1.' '.$x;
- $self->_resp_text($x);
- $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK';
- $r = $1;
- last;
- }
- else {
- $self->_resp($x, $cmd, $set, $callback);
- }
- }
-
- if (defined $self->{_SELECTED}) {
- my $mailbox = $self->{_SELECTED};
- my $cache = $self->{_CACHE}->{$mailbox};
- # can't keep track of the modification sequences
- $self->fail("Mailbox $mailbox doesn't support MODSEQ.")
- if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC');
- $self->fail("Mailbox $mailbox does not support persistent UIDs.")
- if defined $cache->{UIDNOTSTICKY};
- }
-
- return $r;
-}
-
-
-# $self->_capable($capability, [...])
-# Return true if each $capability is listed in the server's CAPABILITY
-# list.
-sub _capable($@) {
- my $self = shift;
- return 0 unless defined $self->{_CAPABILITIES};
- foreach my $cap (@_) {
- return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}};
- }
- return 1;
-}
-
-
-# $self->_capable($extension)
-# Return true if $extension has been enabled by the server, i.e., the
-# server sent an untagged ENABLED response including it.
-sub _enabled($$) {
- my $self = shift;
- my $ext = uc shift;
- grep {$ext eq uc $_} @{$self->{_ENABLED} // []};
-}
-
-
-# $self->_open_mailbox($mailbox)
-# Initialize the internal and persistent caches for $mailbox, and mark
-# it as selected.
-sub _open_mailbox($$) {
- my $self = shift;
- my $mailbox = shift;
-
- # it is safe to wipe cached VANISHED responses or FLAG updates,
- # because interesting stuff must have made the mailbox dirty so
- # we'll get back to it
- $self->{_VANISHED} = [];
- $self->{_MODIFIED} = {};
-
- $self->{_SELECTED} = $mailbox;
- $self->{_CACHE}->{$mailbox} //= {};
-
- # always reset EXISTS to keep track of new mails
- delete $self->{_CACHE}->{$mailbox}->{EXISTS};
-}
-
-
-# $self->_select_or_examine($command, $mailbox, [$seqs, $UIDs])
-# Issue a SELECT or EXAMINE command for the $mailbox. Upon success,
-# change the state to SELECTED, otherwise go back to AUTH.
-# The optional $seqs and $UIDs are used as Message Sequence Match
-# Data for the QRESYNC parameter to the $command.
-sub _select_or_examine($$$;$$) {
- my $self = shift;
- my $command = shift;
- my $mailbox = shift;
- my ($seqs, $uids) = @_;
-
- my $pcache = $self->{_PCACHE}->{$mailbox} //= {};
- my $cache = $self->{_CACHE}->{$mailbox} //= {};
- $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY};
-
- $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive
- $command .= ' '.quote($mailbox);
- if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) {
- $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} "
- ."1:".($pcache->{UIDNEXT}-1);
- $command .= " ($seqs $uids)" if defined $seqs and defined $uids;
- $command .= "))";
- }
-
- if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) {
- # A mailbox is currently selected and the server advertises
- # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox
- # selection until the [CLOSED] response code has been received:
- # all responses before the [CLOSED] response code refer to the
- # previous mailbox ($self->{_SELECTED}), while all subsequent
- # responses refer to the new mailbox $self->{_SELECTED_DELAYED}.
- $self->{_SELECTED_DELAYED} = $mailbox;
- }
- else {
- $self->_open_mailbox($mailbox);
- }
-
- $self->{_STATE} = 'AUTH';
- $self->_send($command);
- $self->{_STATE} = 'SELECTED';
-}
-
-
-
-#############################################################################
-# Parsing methods
-#
-
-# Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed.
-sub _resp_text($$) {
- my $self = shift;
- local $_ = shift;
-
- if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) {
- $self->log($_);
- }
- elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) {
- $self->fail($_);
- }
- elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) {
- $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
- }
- elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) {
- $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] );
- }
- elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) {
- $self->_update_cache($1 => 1);
- }
- elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) {
- $self->_update_cache($1 => $2);
- }
- elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) {
- # RFC 4551/7162 CONDSTORE/QRESYNC
- $self->_update_cache(HIGHESTMODSEQ => $1);
- }
- elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) {
- # RFC 4551/7162 CONDSTORE/QRESYNC
- $self->_update_cache(NOMODSEQ => 1);
- }
- elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) {
- # RFC 7162 CONDSTORE/QRESYNC
- # Update the selected mailbox: previous responses refer to the
- # previous mailbox ($self->{_SELECTED}), while all subsequent
- # responses refer to the new mailbox $self->{_SELECTED_DELAYED}.
- my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic();
- $self->_open_mailbox($mailbox);
- }
- elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) {
- # RFC 5465 NOTIFY
- $self->fail($_);
- }
- elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) {
- # RFC 4315 UIDPLUS
- $self->_update_cache(UIDNOTSTICKY => 1);
- }
-}
-
-# Parse and consume an RFC 3501 nstring (string / "NIL").
-sub _nstring($$) {
- my ($self, $stream) = @_;
- return $$stream =~ s/\ANIL// ? undef : $self->_string($stream);
-}
-
-# Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string).
-sub _astring($$) {
- my ($self, $stream) = @_;
- return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream);
-}
-
-# Parse and consume an RFC 3501 string (quoted / literal).
-sub _string($$) {
- my ($self, $stream) = @_;
- if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) {
- # quoted
- my $str = $1;
- $str =~ s/\\([\x22\x5C])/$1/g;
- return $str;
- }
- elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
- # literal
- $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
- # read a the rest of the response
- $$stream = $self->_getline('[...]');
- return $lit;
- }
- else {
- $self->panic($$stream);
- }
-}
-
-# Parse and consume an RFC 3501 "(" 1*address ")" / "NIL".
-sub _addresses($$) {
- my ($self, $stream) = @_;
- return undef if $$stream =~ s/\ANIL//;
-
- my @addresses;
- $$stream =~ s/\A\(// or $self->panic($$stream);
- while ($$stream =~ s/\A ?\(//) {
- my @addr;
- push @addr, $self->_nstring($stream); # addr-name
- $$stream =~ s/\A // or $self->panic($$stream);
- push @addr, $self->_nstring($stream); # addr-adl
- $$stream =~ s/\A // or $self->panic($$stream);
- push @addr, $self->_nstring($stream); # addr-mailbox
- $$stream =~ s/\A // or $self->panic($$stream);
- push @addr, $self->_nstring($stream); # addr-host
- $$stream =~ s/\A\)// or $self->panic($$stream);
- push @addresses, \@addr;
- }
- $$stream =~ s/\A\)// or $self->panic($$stream);
- return \@addresses;
-}
-
-# Parse and consume an RFC 3501 envelope
-sub _envelope($$) {
- my ($self, $stream) = @_;
- $$stream =~ s/\A\(// or $self->panic($$stream);
-
- my @envelope;
- push @envelope, $self->_nstring($stream); # env-date
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_nstring($stream); # env-subject
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_addresses($stream); # env-from
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_addresses($stream); # env-sender
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_addresses($stream); # env-reply-to
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_addresses($stream); # env-to
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_addresses($stream); # env-cc
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_addresses($stream); # env-bcc
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_nstring($stream); # env-in-reply-to
- $$stream =~ s/\A // or $self->panic($$stream);
- push @envelope, $self->_nstring($stream); # env-message-id
-
- $$stream =~ s/\A\)// or $self->panic($$stream);
- return \@envelope;
-}
-
-# $self->_resp($buf, [$cmd, $callback] )
-# Parse an untagged response line or a continuation request line.
-# (The trailing CRLF must be removed.) The internal cache is
-# automatically updated when needed.
-# If a command and callback are given, the callback is be executed
-# for each (parsed) responses associated with the command.
-sub _resp($$;$$$) {
- my $self = shift;
- local $_ = shift;
- my $cmd = shift;
- my $set = shift;
- my $callback = shift;
- my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED};
-
- if (s/\A\* //) {
- if (s/\ABYE //) {
- undef $self;
- }
- elsif (s/\A(?:OK|NO|BAD) //) {
- $self->_resp_text($_);
- }
- elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) {
- $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
- }
- elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) {
- $cache->{FLAGS} = [ split / /, $1 ];
- }
- elsif (/\A([0-9]+) RECENT\z/) {
- $cache->{RECENT} = $1;
- }
- elsif (/\A([0-9]+) EXISTS\z/) {
- # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT
- if (defined $cache->{EXISTS}) {
- $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS};
- # the actual UIDNEXT is *at least* that
- $cache->{UIDNEXT} += $1 - $cache->{EXISTS} if defined $cache->{UIDNEXT};
- }
- $cache->{EXISTS} = $1;
- }
- elsif (/\A([0-9]+) EXPUNGE\z/) {
- # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
- $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check
- $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC');
- $cache->{EXISTS}--; # explicit EXISTS responses are optional
- }
- elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
- $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
- }
- 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);
- my @attrs = defined $attrs ? split(/ /, $attrs) : ();
- my $mailbox = $self->_astring(\$_);
- $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;
- $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';
- }
- elsif (s/\ASTATUS //) {
- my $mailbox = $self->_astring(\$_);
- /\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->_update_cache_for($mailbox, %status);
- $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS';
- }
- elsif (s/\A([0-9]+) FETCH \(//) {
- $self->panic("$1 <= $cache->{EXISTS}") unless $1 <= $cache->{EXISTS}; # sanity check
- my ($seq, $first) = ($1, 1);
- my %mail;
- while ($_ ne ')') {
- unless (defined $first) {
- s/\A // or $self->panic($_);
- }
- if (s/\AUID ([0-9]+)//) {
- # always present, cf RFC 3501 section 6.4.8
- $mail{UID} = $1;
- # the actual UIDNEXT is *at least* that
- $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} <= $1;
- }
- if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC
- # always present in unsolicited FETCH responses if QRESYNC has been enabled
- $mail{MODSEQ} = $1;
- $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1;
- }
- elsif (s/\AENVELOPE //) {
- $mail{ENVELOPE} = $self->_envelope(\$_);
- }
- elsif (s/\AINTERNALDATE "([^"]+)"//) {
- $mail{INTERNALDATE} = $1;
- }
- elsif (s/\A(?:RFC822|BODY\[\]) //) {
- $mail{RFC822} = $self->_nstring(\$_);
- }
- elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
- $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : [];
- }
- undef $first;
- }
-
- my $uid = $mail{UID} // $self->panic(); # sanity check
- $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
-
- if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
- (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or
- ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) {
- my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS};
- $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ];
- }
- $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set);
- }
- elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE
- $self->{_ENABLED} //= [];
- push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r));
- }
- elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC
- my $earlier = defined $1 ? 1 : 0;
- my $set = $2;
- my $mailbox = $self->{_SELECTED} // $self->panic();
- my $pcache = $self->{_PCACHE}->{$mailbox};
- foreach (split /,/, $set) {
- if (/\A([0-9]+)\z/) {
- $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional
- $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that
- push @{$self->{_VANISHED}}, $1;
- }
- elsif (/\A([0-9]+):([0-9]+)\z/) {
- my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
- $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional
- $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that
- push @{$self->{_VANISHED}}, ($min .. $max);
- }
- }
- }
- }
- elsif (s/\A\+ //) {
- if (defined $callback and $cmd eq 'AUTHENTICATE') {
- my $x = $callback->($_);
- $self->logger("C: ", $x) if $self->{debug};
- $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
- }
- }
- else {
- $self->panic("Unexpected response: ", $_);
- }
-}
-
-
-#############################################################################
-
-return 1;
projects / interimap.git / commitdiff