#!/usr/bin/perl -T

#----------------------------------------------------------------------
# Fast bidirectional synchronization for QRESYNC-capable IMAP servers
# Copyright © 2015-2022 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 <https://www.gnu.org/licenses/>.
#----------------------------------------------------------------------

use v5.14.2;
use strict;
use warnings;

our $VERSION = '0.5.6';
my $NAME = 'interimap';
my $DATABASE_VERSION = 1;
use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
                            bundling auto_version/;
use DBI ':sql_types';
use DBD::SQLite::Constants ':file_open';
use Fcntl qw/O_WRONLY O_CREAT O_EXCL F_GETFD F_SETFD FD_CLOEXEC/;
use List::Util 'first';

use lib "./lib";
use Net::IMAP::InterIMAP 0.5.6 qw/xdg_basedir read_config compact_set/;

# Clean up PATH
$ENV{PATH} = join ':', qw{/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;
}

my @COMMANDS = qw/repair delete rename/;
usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug+ help|h watch:i notify/, @COMMANDS);
usage(0) if $CONFIG{help};
my $COMMAND = do {
    my @command = grep {exists $CONFIG{$_}} @COMMANDS;
    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));
usage(1) if defined $COMMAND and (defined $CONFIG{watch} or defined $CONFIG{notify});
usage(1) if $CONFIG{target} and !(defined $COMMAND and ($COMMAND eq 'delete' or $COMMAND eq 'rename'));
$CONFIG{watch} = $CONFIG{notify} ? 900 : 60 if (defined $CONFIG{watch} or $CONFIG{notify}) and !$CONFIG{watch};
@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive
die "Invalid mailbox name $_" foreach grep !/\A[\x01-\x7F]+\z/, @ARGV;


my $CONF = do {
    my $conffile = delete($CONFIG{config}) // "config";
    $conffile = xdg_basedir( XDG_CONFIG_HOME => ".config", $NAME, $conffile );
    read_config( $conffile
               , [qw/_ local remote/]
               , database => qr/\A(\P{Control}+)\z/
               , logfile => qr/\A(\/\P{Control}+)\z/
               , 'log-prefix' => qr/\A(\P{Control}*)\z/
               , 'list-reference' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]*)\z/
               , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
               , 'list-select-opts' => qr/\A([\x20\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]*)\z/
               , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
               );
};
my ($DBFILE, %LOGGER_CONF, %LIST);

{
    $CONF->{_} //= {};
    $DBFILE = $CONF->{_}->{database};
    $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;
    $DBFILE = xdg_basedir( XDG_DATA_HOME => ".local/share", $NAME, $DBFILE );

    $LOGGER_CONF{'logger-prefix'} = $CONF->{_}->{'log-prefix'} // "%?n?%?m?%n(%m)&%n?: ?";
    if (defined (my $l = $CONF->{_}->{logfile})) {
        require 'POSIX.pm';
        require 'Time/HiRes.pm';
        open my $fd, '>>', $l or die "Can't open $l: $!\n";
        $fd->autoflush(1);
        my $flags = fcntl($fd, F_GETFD, 0)       or die "fcntl F_GETFD: $!";
        fcntl($fd, F_SETFD, $flags | FD_CLOEXEC) or die "fcntl F_SETFD: $!";
        $LOGGER_CONF{'logger-fd'} = $fd;
    }

    $LIST{mailbox} = [@ARGV];
    if (!defined $COMMAND or $COMMAND eq 'repair') {
        if (!@ARGV and defined (my $v = $CONF->{_}->{'list-mailbox'})) {
            my @mailbox;
            do {
                if ($v =~ s/\A[\x21\x23-\x27\x2A-\x5B\x5D-\x7A\x7C-\x7E]+//p) {
                    push @mailbox, ${^MATCH};
                } elsif ($v =~ s/\A\"((?:
                            [\x20\x21\x23-\x5B\x5D-\x7E] |              # the above plus \x20\x28\x29\x7B
                            (?:\\(?:[\x22\x5C0abtnvfr] | x\p{AHex}{2})) # quoted char or hex-encoded pair
                        )+)\"//x) {
                    push @mailbox, $1 =~ s/\\(?:[\x22\x5C0abtnvfr]|x\p{AHex}{2})/"\"${^MATCH}\""/greep;
                }
            } while ($v =~ s/\A\s+//);
            die "Invalid value for list-mailbox: ".$CONF->{_}->{'list-mailbox'}."\n" if $v ne "";
            $LIST{mailbox} = \@mailbox;
        }
        $LIST{'select-opts'} = uc($CONF->{_}->{'list-select-opts'})
            if defined $CONF->{_}->{'list-select-opts'} and $CONF->{_}->{'list-select-opts'} ne "";
        $LIST{params} = [ "SUBSCRIBED" ]; # RFC 5258 - LIST Command Extensions
        push @{$LIST{params}}, "STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)"
            # RFC 5819 - Returning STATUS Information in Extended LIST
            unless $CONFIG{notify};
    }
    if (defined (my $t = $CONFIG{target})) {
        @$t = map { split(",", $_) } @$t;
        die "Invalid target $_\n" foreach grep !/^(?:local|remote|database)$/, @$t;
        $CONFIG{target} = {};
        $CONFIG{target}->{$_} = 1 foreach @$t;
    } else {
        $CONFIG{target} = {};
        $CONFIG{target}->{$_} = 1 foreach qw/local remote database/;
    }
    $CONF->{$_}->{'list-reference'} //= "" foreach qw/local remote/;
}
my $DBH;

# Clean after us
my ($IMAP, $lIMAP, $rIMAP);
sub cleanup() {
    undef $_ foreach grep defined, ($IMAP, $lIMAP, $rIMAP);
    logger(undef, "Cleaning up...") if $CONFIG{debug};
    $LOGGER_CONF{'logger-fd'}->close() if defined $LOGGER_CONF{'logger-fd'};
    $DBH->disconnect() if defined $DBH;
}
$SIG{INT} = sub { msg(undef, $!); cleanup(); exit 1; };
$SIG{TERM} = sub { cleanup(); exit 0; };


#############################################################################
# Open (and maybe create) the database

{
    # don't auto-create in long-lived mode
    unless ($CONFIG{watch} or -e $DBFILE) {
        sysopen(my $fh, $DBFILE, O_WRONLY | O_CREAT | O_EXCL, 0600) or die "Can't create $DBFILE: $!";
        close $fh or warn "close: $!";
    }

    my $dbi_data_source = "dbi:SQLite:dbname=".$DBFILE;
    my %dbi_attrs = (
        AutoCommit => 0,
        RaiseError => 1,
        sqlite_use_immediate_transaction => 1,
        sqlite_open_flags => SQLITE_OPEN_READWRITE
    );

    $DBH = DBI::->connect($dbi_data_source, undef, undef, \%dbi_attrs);
    $DBH->sqlite_busy_timeout(250);
    # Try to lock the database before any network traffic so we can fail
    # early if the database is already locked.
    $DBH->do("PRAGMA locking_mode = EXCLUSIVE");
    $DBH->{AutoCommit} = 1; # turned back off later
    $DBH->do("PRAGMA foreign_keys = OFF"); # toggled later (no-op if not in autocommit mode)
}

sub msg($@) {
    my %h = ( %LOGGER_CONF, name => shift );
    return Net::IMAP::InterIMAP::log(\%h, @_);
}
sub msg2($$@) {
    my $name = shift;
    my $mailbox = mbx_name($name => shift);
    my %h = ( %LOGGER_CONF, name => $name, mailbox => $mailbox );
    return Net::IMAP::InterIMAP::log(\%h, @_);
}
sub logger($@) {
    my %h = ( %LOGGER_CONF, name => shift );
    return Net::IMAP::InterIMAP::logger(\%h, @_);
}
sub fail($@) {
    my $name = shift;
    msg($name, "ERROR: ", @_);
    exit 1;
}
logger(undef, ">>> $NAME $VERSION") if $CONFIG{debug};


#############################################################################
# Connect to the local and remote IMAP servers

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_CONF{$_} foreach keys %LOGGER_CONF;
    $config{'compress'} //= ($name eq 'local' ? 0 : 1);
    $config{keepalive} = 1 if $CONFIG{watch} and $config{type} ne 'tunnel';

    my $client = Net::IMAP::InterIMAP::->new(%config);
    $IMAP->{$name} = { client => $client };

    die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED UIDPLUS/);
    die "Non LIST-STATUS-capable IMAP server.\n" if !$CONFIG{notify} and $client->incapable('LIST-STATUS');
}

# Pretty-print hierarchy delimiter: DQUOTE QUOTED-CHAR DQUOTE / nil
sub print_delimiter($) {
    my $d = shift // return "NIL";
    $d = "\\".$d if $d eq "\\" or $d eq "\"";
    return "\"".$d."\"";
}

# Return the delimiter of the default namespace or reference, and cache the
# result.  Use the cached value if present, otherwise issue a new LIST
# command with the empty mailbox.
sub get_delimiter($$$) {
    my ($name, $imap, $ref) = @_;

    # Use the cached value if present
    return $imap->{delimiter} if exists $imap->{delimiter};

    my (undef, $d) = $imap->{client}->list($ref." \"\""); # $ref is already quoted
    my @d = values %$d if defined $d;
    # While multiple LIST responses may happen in theory, we've issued a
    # single LIST command, so it's fair to expect a single reponse with
    # a hierarchy delimiter of the root node or reference (we can't
    # match the root against the reference as it might not be rooted).
    fail($name, "Missing or unexpected (unsolicited) LIST response.") unless $#d == 0;

    return $imap->{delimiter} = $d[0]; # cache value and return it
}

# List mailboxes; don't return anything but update $IMAP->{$name}->{mailboxes}
sub list_mailboxes($) {
    my $name = shift;
    my $imap = $IMAP->{$name};
    my $ref = Net::IMAP::InterIMAP::quote($CONF->{$name}->{'list-reference'});

    my $list = "";
    $list .= "(" .$LIST{'select-opts'}. ") " if defined $LIST{'select-opts'};
    $list .= $ref." ";

    my @mailboxes = @{$LIST{mailbox}};
    my $cached_delimiter = exists $imap->{delimiter} ? 1 : 0;
    if (grep { index($_,"\x00") >= 0 } @mailboxes) {
        # some mailbox names contain null characters: substitute them with the hierarchy delimiter
        my $d = get_delimiter($name, $imap, $ref) //
            fail($name, "Mailbox name contains null characters but the namespace is flat!");
        s/\x00/$d/g foreach @mailboxes;
    }

    $list .= $#mailboxes  < 0 ? "*"
           : $#mailboxes == 0 ? Net::IMAP::InterIMAP::quote($mailboxes[0])
           : "(".join(" ", map {Net::IMAP::InterIMAP::quote($_)} @mailboxes).")";
    my ($mbx, $delims) = $imap->{client}->list($list, @{$LIST{params} // []});
    $imap->{mailboxes} = $mbx;

    # INBOX exists in a namespace of its own, so it may have a different separator.
    # All other mailboxes MUST have the same separator though, per 3501 sec. 7.2.2
    # and https://imapwiki.org/ClientImplementation/MailboxList#Hierarchy_separators
    # (We assume all list-mailbox arguments given live in the same namespace. Otherwise
    # the user needs to start multiple interimap instances.)
    delete $delims->{INBOX};

    unless (exists $imap->{delimiter}) {
        # if the delimiter is still unknown (meaning no names in @{$LIST{mailbox}}
        # contains null characters) we now cache it
        if (%$delims) {
            # got a non-INBOX LIST reply, use the first one as authoritative value
            my ($m) = sort keys %$delims;
            $imap->{delimiter} = delete $delims->{$m};
        } else {
            # didn't get a non-INBOX LIST reply so we need to explicitly query
            # the hierarchy delimiter
            get_delimiter($name, $imap, $ref);
        }
    }
    logger($name, "Using ", print_delimiter($imap->{delimiter}),
        " as hierarchy delimiter") if !$cached_delimiter and $CONFIG{debug};

    # Ensure all LISTed delimiters (incl. INBOX's children, although they're
    # in a different namespace -- we treat INBOX itself separately, but not
    # its children) match the one at the top level (root or reference).
    my $d = $imap->{delimiter};
    foreach my $m (keys %$delims) {
        fail($name, "Mailbox $m has hierarchy delimiter ", print_delimiter($delims->{$m}),
                ", while ", print_delimiter($d), " was expected.")
            if (defined $d xor defined $delims->{$m})
                or (defined $d and defined $delims->{$m} and $d ne $delims->{$m});
    }
}

list_mailboxes("local");
if (defined (my $d = $IMAP->{local}->{delimiter})) {
    # substitute the local delimiter with null characters in the mailbox list
    s/\Q$d\E/\x00/g foreach @{$LIST{mailbox}};
}
list_mailboxes("remote");

# Ensure local and remote namespaces are either both flat, or both hierarchical.
# (We can't mirror a hierarchical namespace to a flat one.)
fail(undef, "Local and remote namespaces are neither both flat nor both hierarchical ",
        "(local ", print_delimiter($IMAP->{local}->{delimiter}), ", ",
        "remote ", print_delimiter($IMAP->{remote}->{delimiter}), ").")
    if defined $IMAP->{local}->{delimiter} xor defined $IMAP->{remote}->{delimiter};


##############################################################################
# Create or update database schema (delayed until after the IMAP
# connections and mailbox LISTing as we need to know the hierarchy
# delimiter for the schema migration).

{
    # 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`.
    my @schema = (
        mailboxes => [
            q{idx        INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
            # to avoid caching hierachy delimiter of mailbox names forever we replace it
            # with '\0' in that table; the substitution is safe since null characters are
            # not allowed within mailbox names
            q{mailbox    BLOB COLLATE BINARY NOT NULL CHECK (mailbox != '') UNIQUE},
            q{subscribed BOOLEAN NOT NULL}
        ],
        local => [
            q{idx           INTEGER         NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
            # no UNIQUE constraint on UIDVALIDITY as two mailboxes may share the same value
            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 (/!\ converted to 8-byte signed integer)
            # one-to-one correspondence between local.idx and remote.idx
        ],
        remote => [
            q{idx           INTEGER         NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
            # no UNIQUE constraint on UIDVALIDITY as two mailboxes may share the same value
            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 (/!\ converted to 8-byte signed integer)
            # 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)
        ],
    );

    # Use the user_version PRAGMA (0 if unset) to keep track of schema
    # version https://sqlite.org/pragma.html#pragma_user_version
    my ($schema_version) = $DBH->selectrow_array("PRAGMA user_version");

    if ($schema_version < $DATABASE_VERSION) {
        # schema creation or upgrade required
        $DBH->begin_work();
        if ($schema_version == 0) {
            my $sth = $DBH->table_info(undef, undef, undef, "TABLE");
            unless (defined $sth->fetch()) {
                # there are no tables, create everything
                msg(undef, "Creating new schema in database file $DBFILE");
                for (my $i = 0; $i <= $#schema; $i+=2) {
                    $DBH->do("CREATE TABLE $schema[$i] (".join(", ", @{$schema[$i+1]}).")");
                }
                goto SCHEMA_DONE; # skip the below migrations
            }
        }
        msg(undef, "Upgrading database version from $schema_version");
        # 12-step procedure from https://www.sqlite.org/lang_altertable.html
        if ($schema_version < 1) {
            fail(undef, "Local and remote hierachy delimiters differ ",
                    "(local ", print_delimiter($IMAP->{local}->{delimiter}), ", ",
                    "remote ", print_delimiter($IMAP->{remote}->{delimiter}), "), ",
                    "refusing to update table \`mailboxes\`.")
                if defined $IMAP->{local}->{delimiter} and defined $IMAP->{remote}->{delimiter}
                        # we failed earlier if only one of them was NIL
                        and $IMAP->{local}->{delimiter} ne $IMAP->{remote}->{delimiter};
            $DBH->do("CREATE TABLE _tmp${DATABASE_VERSION}_mailboxes (". join(", ",
                q{idx        INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
                q{mailbox    BLOB COLLATE BINARY NOT NULL CHECK (mailbox != '') UNIQUE},
                q{subscribed BOOLEAN NOT NULL}
            ).")");
            if (defined (my $d = $IMAP->{local}->{delimiter})) {
                # local and remote delimiters match, replace them with null characters
                my $sth = $DBH->prepare("INSERT INTO _tmp${DATABASE_VERSION}_mailboxes
                    SELECT idx, CAST(REPLACE(mailbox, ?, x'00') AS BLOB), subscribed FROM mailboxes");
                $sth->bind_param(1, $IMAP->{local}->{delimiter}, SQL_VARCHAR);
                $sth->execute();
            } else {
                # treat all mailboxes as flat (\NoInferiors names)
                $DBH->do("INSERT INTO _tmp${DATABASE_VERSION}_mailboxes SELECT * FROM mailboxes");
            }
            $DBH->do("DROP TABLE mailboxes");
            $DBH->do("ALTER TABLE _tmp${DATABASE_VERSION}_mailboxes RENAME TO mailboxes");
        }
        fail("database", "Broken referential integrity! Refusing to commit changes.")
            if defined $DBH->selectrow_arrayref("PRAGMA foreign_key_check");
        SCHEMA_DONE:
        $DBH->do("PRAGMA user_version = $DATABASE_VERSION");
        $DBH->commit();
    }
    $DBH->do("PRAGMA foreign_keys = ON"); # no-op if not in autocommit mode
    $DBH->{AutoCommit} = 0; # always explicitly commit changes
}


##############################################################################
#

# Add a new mailbox to the database.
# WARN: does not commit changes!
sub db_create_mailbox($$) {
    my ($mailbox, $subscribed) = @_;;
    state $sth = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
    $sth->bind_param(1, $mailbox,    SQL_BLOB);
    $sth->bind_param(2, $subscribed, SQL_BOOLEAN);
    my $r = $sth->execute();
    msg("database", "Created mailbox ", mbx_pretty($mailbox));
    return $r;
}

# Get the index associated with a mailbox.
sub db_get_mailbox_idx($) {
    my $mailbox = shift;
    state $sth = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?});
    $sth->bind_param(1, $mailbox, SQL_BLOB);
    $sth->execute();
    my ($idx, $subscribed) = $sth->fetchrow_array();
    die if defined $sth->fetch(); # safety check (we have a UNIQUE contstraint though)
    return wantarray ? ($idx, $subscribed) : $idx;
}

# Transform mailbox name from internal representation (with \0 as hierarchy delimiters
# and without reference prefix) to a name understandable by the local/remote IMAP server.
sub mbx_name($$) {
    my ($name, $mailbox) = @_;
    my $x = $name // "local"; # don't add reference if $name is undefined
    if (defined (my $d = $IMAP->{$x}->{delimiter})) {
        $mailbox =~ s/\x00/$d/g;
    } elsif (!exists $IMAP->{$x}->{delimiter} or index($mailbox,"\x00") >= 0) {
        die; # safety check
    }
    return defined $name ? ($CONF->{$name}->{"list-reference"} . $mailbox) : $mailbox;
}
sub mbx_pretty($) { return mbx_name(undef, $_[0]); }

# Transform mailbox name from local/remote IMAP server to the internal representation
# (with \0 as hierarchy delimiters and without reference prefix).  Return undef if
# the name doesn't start with the right reference.
sub mbx_unname($$) {
    my ($name, $mailbox) = @_;
    return unless defined $mailbox;

    my $ref = $CONF->{$name}->{"list-reference"};
    return unless rindex($mailbox, $ref, 0) == 0; # not for us
    $mailbox = substr($mailbox, length $ref);

    if (defined (my $d = $IMAP->{$name}->{delimiter})) {
        $mailbox =~ s/\Q$d\E/\x00/g;
    } elsif (!exists $IMAP->{$name}->{delimiter}) {
        die; # safety check
    }
    return $mailbox;
}

# Format a message with format controls for local/remote/database mailbox names.
sub fmt($@) {
    my $msg = shift;
    $msg =~ s/%([lrds])/
                $1 eq "l" ? mbx_name("local",  shift)
              : $1 eq "r" ? mbx_name("remote", shift)
              : $1 eq "d" ? mbx_name(undef,    shift)
              : $1 eq "s" ? shift
              : die
        /ge;
    return $msg;
}

# Return true if $mailbox exists on $name
sub mbx_exists($$) {
    my ($name, $mailbox) = @_;
    my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox};
    my ($ne, $ns) = (lc '\NonExistent', lc '\NoSelect');
    return (defined $attrs and !grep {my $a = lc; $a eq $ne or $a eq $ns} @$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') {
    if (defined (my $d = $IMAP->{local}->{delimiter})) {
        s/\Q$d\E/\x00/g foreach @ARGV;
    }
    my @statements = map { $DBH->prepare("DELETE FROM $_ WHERE idx = ?") }
                         # non-referenced tables first to avoid violating
                         # FOREIGN KEY constraints
                         qw/mapping local remote mailboxes/
        if @ARGV and $CONFIG{target}->{database};
    foreach my $mailbox (@ARGV) {
        fail(undef, "INBOX can't be deleted") if uc($mailbox) eq "INBOX"; # RFC 3501 sec. 6.3.4
        my $idx = db_get_mailbox_idx($mailbox);

        # 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/) {
            my $mbx = mbx_name($name, $mailbox);
            $IMAP->{$name}->{client}->delete($mbx)
                if $CONFIG{target}->{$name} and mbx_exists($name, $mbx);
        }

        if (defined $idx and $CONFIG{target}->{database}) {
            foreach my $sth (@statements) {
                $sth->bind_param(1, $idx, SQL_INTEGER);
                $sth->execute();
            }
            $DBH->commit();
            msg("database", "Removed mailbox ", mbx_pretty($mailbox));
        }
    }
    exit 0;
}


##############################################################################
# Process --rename command
#
elsif (defined $COMMAND and $COMMAND eq 'rename') {
    my ($from, $to) = @ARGV;
    if (defined (my $d = $IMAP->{local}->{delimiter})) {
        s/\Q$d\E/\x00/g foreach ($from, $to);
    }

    # get index of the original name
    my $idx = db_get_mailbox_idx($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/) {
        my $mbx = mbx_name($name, $to);
        next unless $CONFIG{target}->{$name} and mbx_exists($name, $mbx);
        fail($name, "Mailbox $mbx exists. Run `$NAME --target=$name --delete ",
                        mbx_pretty($to), "` to delete.");
    }

    # ensure the target name doesn't already exist in the database
    my $to_pretty = mbx_pretty($to);
    fail("database", "Mailbox $to_pretty exists. Run `$NAME --target=database ",
                        "--delete $to_pretty` to delete.")
        if $CONFIG{target}->{database} and defined db_get_mailbox_idx($to);


    # rename $from to $to on servers where $from if LISTed.  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 unless $CONFIG{target}->{$name};
        my ($from, $to) = ( mbx_name($name,$from), mbx_name($name, $to) );
        # don't use mbx_exists() here, as \NonExistent names can be renamed
        # too (for instance if they have children)
        $IMAP->{$name}->{client}->rename($from, $to)
            if defined $IMAP->{$name}->{mailboxes}->{$from};
    }

    # rename from to $to in the database
    if ($CONFIG{target}->{database}) {
        my $r = 0;
        if (defined $idx) {
            my $sth_rename_mailbox = $DBH->prepare(q{
                UPDATE mailboxes SET mailbox = ? WHERE idx = ?
            });
            $sth_rename_mailbox->bind_param(1, $to,  SQL_BLOB);
            $sth_rename_mailbox->bind_param(2, $idx, SQL_INTEGER);
            $r += $sth_rename_mailbox->execute();
        }

        # now rename the children as well
        my $prefix = $from."\x00";
        my $sth_rename_children = $DBH->prepare(q{
            UPDATE mailboxes SET mailbox = CAST(? || SUBSTR(mailbox,?) AS BLOB)
             WHERE SUBSTR(mailbox,1,?) = ?
        });
        $sth_rename_children->bind_param(1, $to, SQL_BLOB);
        $sth_rename_children->bind_param(2, length($prefix), SQL_INTEGER);
        $sth_rename_children->bind_param(3, length($prefix), SQL_INTEGER);
        $sth_rename_children->bind_param(4, $prefix, SQL_BLOB);
        $r += $sth_rename_children->execute();

        $DBH->commit();
        msg("database", "Renamed mailbox ", mbx_pretty($from), " to ",
                            mbx_pretty($to)) if $r > 0;
    }
    exit 0;
}


##############################################################################
# Synchronize mailbox and subscription lists

sub sync_mailbox_list() {
    my (%mailboxes, @mailboxes);
    state $sth_subscribe = $DBH->prepare(q{
        UPDATE mailboxes SET subscribed = ? WHERE idx = ?
    });
    state $ignore_mailbox = do {
        my $re = $CONF->{_}->{"ignore-mailbox"};
        defined $re ? qr/$re/ : undef
    };

    foreach my $name (qw/local remote/) {
        foreach my $mbx (keys %{$IMAP->{$name}->{mailboxes}}) {
            # exclude names not starting with the given LIST reference; for instance
            # if "list-mailbox" specifies a name starting with a "breakout" character
            $mbx = mbx_unname($name, $mbx) // next;

            # exclude ignored mailboxes (taken from the default config as it doesn't
            # make sense to ignore mailboxes from one side but not the other
            next if !@ARGV and defined $ignore_mailbox and $mbx =~ $ignore_mailbox;
            $mailboxes{$mbx} = 1;
        }
    }

    foreach my $mailbox (keys %mailboxes) {
        my ($lMailbox, $rMailbox) = map {mbx_name($_, $mailbox)} qw/local remote/;
        my $lExists = mbx_exists("local",  $lMailbox);
        my $rExists = mbx_exists("remote", $rMailbox);
        next unless $lExists or $rExists;

        push @mailboxes, $mailbox;
        my ($idx, $subscribed) = db_get_mailbox_idx($mailbox);

        if ($lExists and $rExists) {
            # $mailbox exists on both sides
            my $lSubscribed = mbx_subscribed("local",  $lMailbox);
            my $rSubscribed = mbx_subscribed("remote", $rMailbox);
            if (defined $idx) {
                if ($lSubscribed xor $rSubscribed) {
                    # mailbox is subscribed on only one server
                    if ($subscribed) { # unsubscribe
                        my ($imap, $mbx) = $lSubscribed ? ($lIMAP, $lMailbox) : ($rIMAP, $rMailbox);
                        $imap->unsubscribe($mbx);
                    } else { # subscribe
                        my ($imap, $mbx) = $lSubscribed ? ($rIMAP, $rMailbox) : ($lIMAP, $lMailbox);
                        $imap->subscribe($mbx);
                    }
                    # toggle subscribtion in the database
                    $subscribed = $subscribed ? 0 : 1;
                    $sth_subscribe->bind_param(1, $subscribed, SQL_BOOLEAN);
                    $sth_subscribe->bind_param(2, $idx,        SQL_INTEGER);
                    $sth_subscribe->execute();
                    $DBH->commit();
                }
                # $mailbox is either subscribed on both servers, or unsubscribed on both
                elsif ($lSubscribed xor $subscribed) {
                    # $lSubscribed == $rSubscribed but database needs updating
                    $sth_subscribe->bind_param(1, $lSubscribed, SQL_BOOLEAN);
                    $sth_subscribe->bind_param(2, $idx,         SQL_INTEGER);
                    $sth_subscribe->execute();
                    $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;
                db_create_mailbox($mailbox, $subscribed);
                $IMAP->{local}->{client}->subscribe($lMailbox)  if $subscribed and !$lSubscribed;
                $IMAP->{remote}->{client}->subscribe($rMailbox) if $subscribed and !$rSubscribed;
                $DBH->commit();
            }
        }
        elsif ($lExists or $rExists) {
            # $mailbox is on one server only
            my $str = mbx_pretty($mailbox);
            fail("database", "Mailbox $str exists. Run `$NAME --target=database --delete $str` to delete.")
                if defined $idx;
            my ($name1, $name2, $mbx1, $mbx2) = $lExists ? ("local", "remote", $lMailbox, $rMailbox)
                                                         : ("remote", "local", $rMailbox, $lMailbox);
            my $subscribed = mbx_subscribed($name1, $mbx1);
            db_create_mailbox($mailbox, $subscribed);
            $IMAP->{$name2}->{client}->create($mbx2, 1);
            $IMAP->{$name2}->{client}->subscribe($mbx2) if $subscribed;
            $DBH->commit();
        }
    }
    return @mailboxes;
}

($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
my @MAILBOXES = sync_mailbox_list();
my $ATTRS = join ' ', qw/MODSEQ FLAGS INTERNALDATE BODY.PEEK[]/;


#############################################################################
# Synchronize messages

# Download some missing UIDs from $source; returns the new 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');

    ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($ATTRS ENVELOPE)", sub($) {
        my $mail = shift;
        return unless exists $mail->{RFC822}; # not for us

        unless ($CONFIG{quiet}) {
            my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
            $from = (defined $from and defined $from->[0]->[2] and defined $from->[0]->[3])
                  ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
            msg2($source => $mailbox, "UID $mail->{UID} from <$from> ($mail->{INTERNALDATE})");
        }
        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 ", mbx_pretty($mailbox),
                " for local UID $lUID ($lFlags) and remote UID $rUID ($rFlags).",
                " Setting both to the union ($flags).");
    return $flags
}


# Delete a mapping ($idx, $lUID) from the database
# WARN: Never commit before the messages have been EXPUNGEd on both sides!
sub delete_mapping($$) {
    my ($idx, $lUID) = @_;
    state $sth = $DBH->prepare(q{
        DELETE FROM mapping WHERE idx = ? and lUID = ?
    });
    $sth->bind_param(1, $idx,  SQL_INTEGER);
    $sth->bind_param(2, $lUID, SQL_INTEGER);
    my $r = $sth->execute();
    die if $r > 1; # safety check (even if we have a UNIQUE constraint)
    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 (once compacted) at most 256.
# The reason why we sample with the highest UIDs is that lowest UIDs are
# less likely to be deleted.
sub sample($$) {
    my ($count, $sth) = @_;
    return unless $count > 0;
    my ($n, $uids, $min, $max);

    $sth->execute(); # /!\ assume placeholders are bound already
    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) > 256) {
                $sth->finish(); # done with the statement
                last;
            }
        }
    }
    if (!defined $uids or length($uids) <= 256) {
        # exceed max size by at most 22 bytes ("$MIN:$MAX,")
        $n += $max - $min + 1;
        $uids = ($min == $max  ? $min : "$min:$max")
              . (defined $uids ? ','.$uids : '');
    }
    die unless $n <= $count; # impossible
    return ( ($count - $n + 1).':'.$count, $uids );
}


# Issue a SELECT command with the given $mailbox.
sub select_mbx($$) {
    my ($idx, $mailbox) = @_;

    # Count messages
    state $sth_count_messages = $DBH->prepare(q{
        SELECT COUNT(*) FROM mapping WHERE idx = ?
    });
    $sth_count_messages->bind_param(1, $idx, SQL_INTEGER);
    $sth_count_messages->execute();

    my ($count) = $sth_count_messages->fetchrow_array();
    $sth_count_messages->finish();

    # List last 1024 messages UIDs
    state $sth_last_lUIDs = $DBH->prepare(q{
        SELECT lUID FROM mapping
         WHERE idx = ?
         ORDER BY lUID DESC
         LIMIT 1024
    });
    state $sth_last_rUIDs = $DBH->prepare(q{
        SELECT rUID FROM mapping
         WHERE idx = ?
         ORDER BY rUID DESC
         LIMIT 1024
    });

    $_->bind_param(1, $idx, SQL_INTEGER) foreach ($sth_last_lUIDs, $sth_last_rUIDs);
    $lIMAP->select(mbx_name(local  => $mailbox), sample($count, $sth_last_lUIDs));
    $rIMAP->select(mbx_name(remote => $mailbox), sample($count, $sth_last_rUIDs));
}


# 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;
    my $idx   = db_get_mailbox_idx($mailbox) // return; # not in the database
    my $cache = db_get_cache_by_idx($idx)    // return; # no cache

    # don't use select_mbx() as we don't need to sample here
    $lIMAP->select(mbx_name(local  => $mailbox));
    $rIMAP->select(mbx_name(remote => $mailbox));

    # get all existing UID with their flags
    my ($lVanished, $lModified) = $lIMAP->pull_updates(1);
    my ($rVanished, $rModified) = $rIMAP->pull_updates(1);

    my (%lVanished, %rVanished);
    $lVanished{$_} = 1 foreach @$lVanished;
    $rVanished{$_} = 1 foreach @$rVanished;

    my (@lToRemove, %lToUpdate, @lMissing);
    my (@rToRemove, %rToUpdate, @rMissing);
    my @delete_mapping;

    # process each pair ($lUID,$rUID) found in the mapping table for the given index,
    # and compare with the result from the IMAP servers to detect anomalies
    state $sth_get_mappings = $DBH->prepare(q{
        SELECT lUID,rUID FROM mapping WHERE idx = ?
    });
    $sth_get_mappings->bind_param(1, $idx, SQL_INTEGER);
    $sth_get_mappings->execute();
    while (defined (my $row = $sth_get_mappings->fetchrow_arrayref())) {
        my ($lUID, $rUID) = @$row;
        if (defined (my $l = $lModified->{$lUID}) and defined (my $r = $rModified->{$rUID})) {
            # both $lUID and $rUID are known; see sync_known_messages
            # for the sync algorithm
            my ($lModSeq, $lFlags) = @$l;
            my ($rModSeq, $rFlags) = @$r;
            if ($lFlags eq $rFlags) {
                # no conflict, whee
            }
            elsif ($lModSeq <= $cache->{lHIGHESTMODSEQ} and $rModSeq > $cache->{rHIGHESTMODSEQ}) {
                # set $lUID to $rFlags
                $lToUpdate{$rFlags} //= [];
                push @{$lToUpdate{$rFlags}}, $lUID;
            }
            elsif ($lModSeq > $cache->{lHIGHESTMODSEQ} and $rModSeq <= $cache->{rHIGHESTMODSEQ}) {
                # set $rUID to $lFlags
                $rToUpdate{$lFlags} //= [];
                push @{$rToUpdate{$lFlags}}, $rUID;
            }
            else {
                # conflict
                msg(undef, "WARNING: Missed flag update in ", mbx_pretty($mailbox),
                                " for (lUID,rUID) = ($lUID,$rUID). Repairing.")
                    if $lModSeq <= $cache->{lHIGHESTMODSEQ} and $rModSeq <= $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}) {
            push @delete_mapping, $lUID;
            msg(undef, "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from ",
                            mbx_pretty($mailbox), ". Repairing.")
                unless $lVanished{$lUID} and $rVanished{$rUID};
        }
        elsif (!defined $lModified->{$lUID}) {
            push @delete_mapping, $lUID;
            if ($lVanished{$lUID}) {
                push @rToRemove, $rUID;
            } else {
                msg2(local => $mailbox, "WARNING: UID $lUID disappeared. Redownloading remote UID $rUID.");
                push @rMissing, $rUID;
            }
        }
        elsif (!defined $rModified->{$rUID}) {
            push @delete_mapping, $lUID;
            if ($rVanished{$rUID}) {
                push @lToRemove, $lUID;
            } else {
                msg2(remote => $mailbox, "WARNING: UID $rUID disappeared. Redownloading local UID $lUID.");
                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;
    msg2(remote => $mailbox, "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) "
                            .compact_set(@lDunno).". Ignoring.") if @lDunno;
    msg2(local => $mailbox,  "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) "
                            .compact_set(@rDunno).". Ignoring.") if @rDunno;

    foreach my $lUID (keys %$lModified) {
        msg2(remote => $mailbox, "WARNING: No match for modified local UID $lUID. Redownloading.");
        push @lMissing, $lUID;
    }
    foreach my $rUID (keys %$rModified) {
        msg2(local => $mailbox, "WARNING: No match for modified remote UID $rUID. Redownloading.");
        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;

    # Find local/remote UID from the mapping table.
    state $sth_get_local_uid = $DBH->prepare(q{
        SELECT lUID
          FROM mapping
         WHERE idx = ? and rUID = ?
    });
    state $sth_get_remote_uid = $DBH->prepare(q{
        SELECT rUID
          FROM mapping
         WHERE idx = ? and lUID = ?
    });

    # loop since processing might produce VANISHED or unsolicited 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->bind_param(1, $idx,  SQL_INTEGER);
                $sth_get_remote_uid->bind_param(2, $lUID, SQL_INTEGER);
                $sth_get_remote_uid->execute();
                my ($rUID) = $sth_get_remote_uid->fetchrow_array();
                die if defined $sth_get_remote_uid->fetch(); # safety check
                if (!defined $rUID) {
                    push @lDunno, $lUID;
                } elsif (!exists $rVanished{$rUID}) {
                    push @rToRemove, $rUID;
                }
            }
            foreach my $rUID (@$rVanished) {
                $sth_get_local_uid->bind_param(1, $idx,  SQL_INTEGER);
                $sth_get_local_uid->bind_param(2, $rUID, SQL_INTEGER);
                $sth_get_local_uid->execute();
                my ($lUID) = $sth_get_local_uid->fetchrow_array();
                die if defined $sth_get_local_uid->fetch(); # safety check
                if (!defined $lUID) {
                    push @rDunno, $rUID;
                } elsif (!exists $lVanished{$lUID}) {
                    push @lToRemove, $lUID;
                }
            }

            msg2(remote => $mailbox, "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) "
                                    .compact_set(@lDunno).". Ignoring.") if @lDunno;
            msg2(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->bind_param(1, $idx,  SQL_INTEGER);
                $sth_get_remote_uid->bind_param(2, $lUID, SQL_INTEGER);
                $sth_get_remote_uid->execute();
                my ($rUID) = $sth_get_remote_uid->fetchrow_array();
                die if defined $sth_get_remote_uid->fetch(); # safety check
                if (!defined $rUID) {
                    msg2(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->bind_param(1, $idx,  SQL_INTEGER);
                $sth_get_local_uid->bind_param(2, $rUID, SQL_INTEGER);
                $sth_get_local_uid->execute();
                my ($lUID) = $sth_get_local_uid->fetchrow_array();
                die if defined $sth_get_local_uid->fetch(); # safety check
                if (!defined $lUID) {
                    msg2(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) {
        # the RFC822 attribute can be NIL or empty (it's an nstring), however
        # NIL can't be used in APPEND commands, and RFC 3502 sec. 6.3.11
        # explicitly forbids zero-length messages, so we ignore these here
        msg2($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 128/1MiB to save roundtrips without blowing up the memory
        if ($#$buff >= 127 or (@$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 $target = $name eq "local" ? "remote" : "local";
    my $imap = $target eq "local" ? $lIMAP : $rIMAP; # target client
    my @sUID = map {$_->{UID}} @messages;
    my @tUID = $imap->append(mbx_name($target, $mailbox), @messages);
    die unless $#sUID == $#tUID; # sanity check

    state $sth = $DBH->prepare(q{
        INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)
    });
    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 ", mbx_pretty($mailbox))
            if $CONFIG{debug};
        $sth->bind_param(1, $idx,         SQL_INTEGER);
        $sth->bind_param(2, $lUIDs->[$k], SQL_INTEGER);
        $sth->bind_param(3, $rUIDs->[$k], SQL_INTEGER);
        $sth->execute();
    }
    $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($ATTRS, 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

    state $sth_update_local = $DBH->prepare(q{
        UPDATE local
           SET UIDNEXT = ?, HIGHESTMODSEQ = ?
         WHERE idx = ?
    });
    state $sth_update_remote = $DBH->prepare(q{
        UPDATE remote
           SET UIDNEXT = ?, HIGHESTMODSEQ = ?
         WHERE idx = ?
    });

    my ($lUIDNEXT, $lHIGHESTMODSEQ) = $lIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/);
    $sth_update_local->bind_param(1, $lUIDNEXT,                        SQL_INTEGER);
    $sth_update_local->bind_param(2, sprintf("%lld", $lHIGHESTMODSEQ), SQL_BIGINT);
    $sth_update_local->bind_param(3, $idx,                             SQL_INTEGER);
    $sth_update_local->execute();

    my ($rUIDNEXT, $rHIGHESTMODSEQ) = $rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/);
    $sth_update_remote->bind_param(1, $rUIDNEXT,                        SQL_INTEGER);
    $sth_update_remote->bind_param(2, sprintf("%lld", $rHIGHESTMODSEQ), SQL_BIGINT);
    $sth_update_remote->bind_param(3, $idx,                             SQL_INTEGER);
    $sth_update_remote->execute();

    $DBH->commit();
}


#############################################################################
# Resume interrupted mailbox syncs (before initializing the cache).
#
my ($MAILBOX, $IDX); # current mailbox, and its index in our database

sub db_get_cache_by_idx($) {
    my $idx = shift;
    state $sth = $DBH->prepare(q{
        SELECT 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 local l JOIN remote r ON l.idx = r.idx
        WHERE l.idx = ?
    });
    $sth->bind_param(1, $idx, SQL_INTEGER);
    $sth->execute();
    my $cache = $sth->fetchrow_hashref();
    die if defined $sth->fetch(); # safety check
    if (defined $cache) {
        $cache->{$_} = sprintf("%llu", $cache->{$_}) foreach qw/lHIGHESTMODSEQ rHIGHESTMODSEQ/;
    }
    return $cache;
}

{
    # Get the list of interrupted mailbox syncs.
    my $sth_list = $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_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 (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT)
           AND m.idx = ?
    });

    $sth_list->execute();
    while (defined (my $row = $sth_list->fetchrow_arrayref())) {
        next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailboxes

        ($IDX, $MAILBOX) = @$row;
        msg(undef, "Resuming interrupted sync for ", mbx_pretty($MAILBOX));
        my $cache = db_get_cache_by_idx($IDX) // die; # safety check
        my ($lMailbox, $rMailbox) = map {mbx_name($_, $MAILBOX)} qw/local remote/;

        my %lUIDs;
        $sth_get_by_idx->bind_param(1, $IDX, SQL_INTEGER);
        $sth_get_by_idx->execute();
        while (defined (my $row = $sth_get_by_idx->fetchrow_arrayref())) {
            $lUIDs{$row->[0]} = $row->[1]; # pair ($lUID, $rUID)
        }
        die unless %lUIDs; # sanity check

        $lIMAP->select($lMailbox);
        $rIMAP->select($rMailbox);

        # 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 = "(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.)
        $lIMAP->set_cache($lMailbox,
            UIDVALIDITY => $cache->{lUIDVALIDITY},
            UIDNEXT     => $cache->{lUIDNEXT}
        );
        $rIMAP->set_cache($rMailbox,
            UIDVALIDITY => $cache->{rUIDVALIDITY},
            UIDNEXT     => $cache->{rUIDNEXT}
        );
        sync_messages($IDX, $MAILBOX, [keys %lList], [keys %rList]);
    }
}


#############################################################################
# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
#

my %KNOWN_INDEXES;
{
    # Get all cached states from the database.
    my $sth = $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
    });

    $sth->execute();
    while (defined (my $row = $sth->fetchrow_hashref())) {
        next unless grep {$row->{mailbox} eq $_} @MAILBOXES;
        $lIMAP->set_cache(mbx_name(local => $row->{mailbox}),
            UIDVALIDITY   => $row->{lUIDVALIDITY},
            UIDNEXT       => $row->{lUIDNEXT},
            HIGHESTMODSEQ => sprintf("%llu", $row->{lHIGHESTMODSEQ})
        );
        $rIMAP->set_cache(mbx_name(remote => $row->{mailbox}),
            UIDVALIDITY   => $row->{rUIDVALIDITY},
            UIDNEXT       => $row->{rUIDNEXT},
            HIGHESTMODSEQ => sprintf("%llu", $row->{rHIGHESTMODSEQ})
        );
        $KNOWN_INDEXES{$row->{idx}} = 1;
    }
}

if (defined $COMMAND and $COMMAND eq 'repair') {
    repair($_) foreach @MAILBOXES;
    exit 0;
}


if ($CONFIG{notify}) {
	# 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.
    foreach my $name (qw/local remote/) {
        my $mailboxes = join(' ', map {Net::IMAP::InterIMAP::quote(mbx_name($name, $_))} @MAILBOXES);
        my %mailboxes = map { $_ => [qw/MessageNew MessageExpunge FlagChange/] }
                            ( "MAILBOXES ($mailboxes)", 'SELECTED' );
        my %personal = ( personal => [qw/MailboxName SubscriptionChange/] );
        my $imap = $name eq "local" ? $lIMAP : $rIMAP;

        # require STATUS responses for our @MAILBOXES only
        $imap->notify('SET STATUS', %mailboxes);
        $imap->notify('SET', %mailboxes, %personal);
    }
}


sub loop() {
    state $sth_insert_local = $DBH->prepare(q{
        INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)
    });
    state $sth_insert_remote = $DBH->prepare(q{
        INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)
    });

    state $sth_update_local_highestmodseq = $DBH->prepare(q{
        UPDATE local
           SET HIGHESTMODSEQ = ?
         WHERE idx = ?
    });
    state $sth_update_remote_highestmodseq = $DBH->prepare(q{
        UPDATE remote
           SET HIGHESTMODSEQ = ?
         WHERE idx = ?
    });

    while(@MAILBOXES) {
        if (defined $MAILBOX and ($lIMAP->is_dirty(mbx_name(local => $MAILBOX)) or $rIMAP->is_dirty(mbx_name(remote => $MAILBOX)))) {
            # $MAILBOX is dirty on either the local or remote mailbox
            sync_messages($IDX, $MAILBOX);
        }
        else {
            $MAILBOX = mbx_unname(local  => $lIMAP->next_dirty_mailbox(map {mbx_name(local  => $_)} @MAILBOXES))
                    // mbx_unname(remote => $rIMAP->next_dirty_mailbox(map {mbx_name(remote => $_)} @MAILBOXES))
                    // last;

            $IDX = db_get_mailbox_idx($MAILBOX) // die; # safety check
            select_mbx($IDX, $MAILBOX);

            if (!$KNOWN_INDEXES{$IDX}) {
                my $lUIDVALIDITY = $lIMAP->uidvalidity(mbx_name(local => $MAILBOX));
                $sth_insert_local->bind_param(1, $IDX,          SQL_INTEGER);
                $sth_insert_local->bind_param(2, $lUIDVALIDITY, SQL_INTEGER);
                $sth_insert_local->execute();

                my $rUIDVALIDITY = $rIMAP->uidvalidity(mbx_name(remote => $MAILBOX));
                $sth_insert_remote->bind_param(1, $IDX,          SQL_INTEGER);
                $sth_insert_remote->bind_param(2, $rUIDVALIDITY, SQL_INTEGER);
                $sth_insert_remote->execute();

                # 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
                my $lHIGHESTMODSEQ = sprintf "%lld", $lIMAP->get_cache(qw/HIGHESTMODSEQ/);
                $sth_update_local_highestmodseq->bind_param(1, $lHIGHESTMODSEQ, SQL_BIGINT);
                $sth_update_local_highestmodseq->bind_param(2, $IDX,            SQL_INTEGER);
                $sth_update_local_highestmodseq->execute();

                my $rHIGHESTMODSEQ = sprintf "%lld", $rIMAP->get_cache(qw/HIGHESTMODSEQ/);
                $sth_update_remote_highestmodseq->bind_param(1, $rHIGHESTMODSEQ, SQL_BIGINT);
                $sth_update_remote_highestmodseq->bind_param(2, $IDX,            SQL_INTEGER);
                $sth_update_remote_highestmodseq->execute();
                $DBH->commit();
            }
            sync_messages($IDX, $MAILBOX);
        }
    }
}
sub notify(@) {
    # TODO: interpret LIST responses to detect mailbox
    # creation/deletion/subcription/unsubscription
    # mailbox creation
    #   * LIST () "/" test
    # mailbox subscribtion
    #   * LIST (\Subscribed) "/" test
    # mailbox unsubscribtion
    #   * LIST () "/" test
    # mailbox renaming
    #   * LIST () "/" test2 ("OLDNAME" (test))
    # mailbox deletion
    #   * LIST (\NonExistent) "/" test2
    unless (Net::IMAP::InterIMAP::slurp(\@_, $CONFIG{watch}, \&Net::IMAP::InterIMAP::is_dirty)) {
        $_->noop() foreach @_;
    }
}

unless (defined $CONFIG{watch}) {
    loop();
    exit 0;
}

while (1) {
    loop();

    if ($CONFIG{notify}) {
        notify($lIMAP, $rIMAP);
    }
    else {
        # we need to issue a NOOP command or go back to AUTH state since the
        # LIST command may not report the correct HIGHESTMODSEQ value for
        # the mailbox currently selected
        # RFC3501: "The STATUS command MUST NOT be used as a "check for
        #           new messages in the selected mailbox" operation"
        if (defined $MAILBOX) {
            # Prefer UNSELECT over NOOP commands as it requires a single command per cycle
            if ($lIMAP->incapable('UNSELECT') or $rIMAP->incapable('UNSELECT')) {
                $_->noop() foreach ($lIMAP, $rIMAP);
            } else {
                $_->unselect() foreach ($lIMAP, $rIMAP);
                undef $MAILBOX;
            }
        }

        sleep $CONFIG{watch};
        # refresh the mailbox list and status
        list_mailboxes($_) for qw/local remote/;
        @MAILBOXES = sync_mailbox_list();
    }
}

END { cleanup(); }