path: root/imapsync

#!/usr/bin/perl -T

#----------------------------------------------------------------------
# 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/>.
#----------------------------------------------------------------------

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 List::Util 'first';
use DBI ();

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;
    print STDERR "TODO $NAME usage\n";
    exit $rv;
}
usage(1) unless GetOptions(\%CONFIG, qw/debug help|h config=s quiet|q oneshot|1 check/);
usage(0) if $CONFIG{help};


my $CONF = read_config( delete $CONFIG{config} // $NAME
                      , [qw/_ local remote/]
                      , database => qr/\A(\P{Control}+)\z/ );
my ($DBFILE, $LOCKFILE);

{
    $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 "Cannot mkdir $dir: $!\n";
        }
    }

    $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r;
}
my ($DBH, $IMAP);


# Clean after us
sub clean() {
    print STDERR "Cleaning...\n" if $CONFIG{debug};
    unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
    undef $_ foreach grep defined, map {$IMAP->{$_}->{client}} keys %$IMAP;
    $DBH->disconnect() if defined $DBH;
}
$SIG{$_} = sub { clean(); die "$!\n"; } foreach qw/INT TERM/;


#############################################################################
# Lock the database
{
    if (-f $LOCKFILE) {
        open my $lock, '<', $LOCKFILE or die "Cannot 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 "Cannot 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 CHECK (UIDNEXT > 0)},
            q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)}
            # 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 CHECK (UIDNEXT > 0)},
            q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)}
            # 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
            # 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 @_;
    my $prefix = defined $name ? "$name: " : '';
    print STDERR $prefix, @_, "\n";
}


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

foreach my $name (qw/local remote/) {
    my %config = %{$CONF->{$name}};
    $config{$_} = $CONFIG{$_} foreach keys %CONFIG;
    $config{enable} = 'QRESYNC';
    $config{name} = $name;

    $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).')');
    $client->notify(qw/SELECTED SUBSCRIBED/) unless $CONFIG{oneshot};
    # 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
    @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list(q{"" "*"}, 'SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)' );
}


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

sub make_tree(%);
sub print_tree($%);
sub mv_tree($$$%);
sub sync_tree($$%);

# Take a hash of delimiters, and recursively build a tree out of it.
# For instance ( a => "/", b => "/", "a/c" => ".", "a/c.d" => "/", "a/d" => ".")
# is transformed into the hash reference
#   { b => {},
#   { a => { "/c" => { ".d" => {} } }
#          , "/d" => {}
#          }
#   }
sub make_tree(%) {
    my %delims = @_;
    my @list = sort {length($a) <=> length($b)} keys %delims;

    my %tree;
    foreach my $x (@list) {
        next unless exists $delims{$x}; # already a children of something
        my %children;
        foreach (keys %delims) {
            next unless defined $delims{$x} and s/\A\Q$x$delims{$x}\E/$delims{$x}/;
            $children{$_} = delete $delims{"$x$_"};
        }
        delete $delims{$x};
        $tree{$x} = make_tree(%children);
    }
    return \%tree;
}
#sub print_tree($%) {
#    my $indent = shift;
#    my %tree = @_;
#    while (my ($root, $children) = each %tree) {
#        print " "x$indent, '|- ', $root, "\n";
#        print_tree($indent+2, %$children);
#    }
#}

# Retrun true if $mailbox exists for $name that is, if doesn't have the
# '\NonExistent' flag set.
sub exists_mbx($$) {
    my $name = shift;
    my $mailbox = shift;
    my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox};
    return (defined $flags and !grep {lc $_ eq lc '\NonExistent'} @$flags) ? 1 : 0;
}
# Retrun true if $mailbox is subscribed for $name.
sub subscribed_mbx($$) {
    my $name = shift;
    my $mailbox = shift;
    my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox};
    return (defined $flags and grep {lc $_ eq lc '\Subscribed'} @$flags) ? 1 : 0;
}

# Rename a root recursively in a tree
sub mv_tree($$$%) {
    my ($mailboxes, $mbx, $mbx2, %children) = @_;
    $mailboxes->{$mbx2} = delete $mailboxes->{$mbx};
    while (my ($root, $children) = each %children) {
        mv_tree($mailboxes, $mbx.$root, $mbx2.$root, %children);
    }
}

# Syncronize mailbox list
# XXX DELETE and RENAME not tested
sub sync_tree($$%) {
    my ($sth, $mbx, %children) = @_;
    my %exists = map { $_ => exists_mbx($_,$mbx) } qw/local remote/;

    my $rv = 0;
    if ($exists{local} xor $exists{remote}) {
        my ($exists,$missing) = $exists{local} ? ('local','remote') : ('remote','local');
        my ($sth_by_mbx, $sth_by_uidvalidity) = @$sth{($missing.'_by_mbx', $exists.'_by_uidvalidity')};

        # check if there is an entry matching $mbx for $missing in the database
        $sth_by_mbx->execute($mbx);
        my $row_by_mbx = $sth_by_mbx->fetch();
        die if defined $sth_by_mbx->fetch(); # sanity check

        if (defined $row_by_mbx) {
            # $mbx was seen on $missing during the previous round: it
            # has either been DELETEd or RENAMEd to another name on
            # $missing.

            my %uidvalidities = $IMAP->{$missing}->{client}->uidvalidity();
            my ($idx,$uidvalidity) = @$row_by_mbx;
            my @mbx2 = grep { $uidvalidities{$_} == $uidvalidity and !exists_mbx($exists,$_) }
                            keys %uidvalidities;

            if ($#mbx2 > 0) {
                # XXX this is allowed by RFC3501, but we can't guess...
                msg($missing, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ",
                              join(',',@mbx2), "\n",
                             "Dunno which one $mbx should be renamed to.");
                exit 1;
            }
            elsif (@mbx2) {
                # $mbx's known (from the DB) UIDVALIDITY is that of
                # $missing's $mbx2, which is not in the database and
                # doesn't exist on $exists
                msg($exists, "Rename mailbox $mbx to $mbx2[0]");
                $sth->{rename}->execute($mbx2[0],$idx);
                $IMAP->{$exists}->{client}->rename($mbx, $mbx2[0]);
                $DBH->commit();
                mv_tree($IMAP->{$exists}->{mailboxes}, $mbx, $mbx2[0], %children);
                $mbx = $mbx2[0];
            }
            else {
                # $mbx's known (from the DB) UIDVALIDITY on $missing
                # was not found in any of $missing's mailboxes.
                msg($exists, "Delete mailbox $mbx");
                push @{$IMAP->{$exists}->{mailboxes}->{$mbx}}, '\NonExistent';
                $IMAP->{$exists}->{client}->delete($mbx);
            }
        }
        else {
            # $mbx was never seen on $missing: it has either been
            # CREATEd or RENAMEd from another name on $exists.

            my ($idx,$mbx2);
            if (defined (my $uidvalidity = $IMAP->{$exists}->{client}->uidvalidity($mbx))) {
                $sth_by_uidvalidity->execute($uidvalidity);
                my $by_uidvalidity = $sth_by_uidvalidity->fetchall_arrayref();
                if (defined $by_uidvalidity and $#$by_uidvalidity > 0) {
                    # XXX this is allowed by RFC3501, but we can't guess...
                    my @mbx2 = map {$_->[1]} @$by_uidvalidity;
                    msg($exists, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ",
                                  join(',',@mbx2), "\n",
                                 "Dunno which one $mbx should be renamed to.");
                    exit 1;
                }
                ($idx,$mbx2) = @{$by_uidvalidity->[0]} if defined $by_uidvalidity and @$by_uidvalidity;
            }

            if (defined $mbx2) {
                # $mbx's UIDVALIDITY on $exists can be found in the
                # database as associated with $mbx2, which exists on
                # $missing but not on $exists
                msg($missing, "Rename mailbox $mbx2 to $mbx");
                $sth->{rename}->execute($mbx,$idx);
                $IMAP->{$missing}->{client}->rename($mbx2, $mbx);
                $DBH->commit();
                mv_tree($IMAP->{$missing}->{mailboxes}, $mbx2, $mbx, %children);
            }
            else {
                # $mbx's UIDVALIDITY on $exists has never been found in
                # the database.
                msg($missing, "Create mailbox $mbx");
                $IMAP->{$missing}->{mailboxes}->{$mbx} =
                    grep {lc $_ ne lc '\NonExistent'} @{$IMAP->{$missing}->{mailboxes}->{$mbx} // []};
                $IMAP->{$missing}->{client}->create($mbx);
            }
        }
        $rv = 1;
    }

    while (my ($root, $children) = each %children) {
        my $r = sync_tree($sth, $mbx.$root, %$children);
        $rv ||= $r;
    }
    return $rv;
}

{
    my %delims;
    foreach my $name (qw/local remote/) {
        while (my ($mbx, $sep) = each %{$IMAP->{$name}->{delims}}) {
            if (!exists $delims{$mbx}) {
                $delims{$mbx} = $sep;
            } else {
                die "Hierarchy delimeters for mailbox $mbx don't match!\n"
                    unless (!defined $sep and !defined $delims{$mbx}) or
                           (defined $sep and defined $delims{$mbx} and $sep eq $delims{$mbx});
            }
        }
    }

    my $tree = make_tree(%delims);
    my %sth;
    $sth{$_.'_by_mbx'} = $DBH->prepare("SELECT idx,UIDVALIDITY FROM mailboxes NATURAL JOIN $_ WHERE mailbox = ?")
        foreach qw/local remote/;
    $sth{$_.'_by_uidvalidity'} = $DBH->prepare("SELECT idx,mailbox FROM mailboxes NATURAL JOIN $_ WHERE UIDVALIDITY = ?")
        foreach qw/local remote/;
    $sth{rename} = $DBH->prepare("UPDATE mailboxes SET mailbox = ? WHERE idx = ?");

    my $updated = 0;
    while (my ($mbx,$children) = each %$tree) {
        #print $mbx, "\n";
        #print_tree(0, %$children);
        my $u = sync_tree(\%sth, $mbx, %$children);
        $updated ||= $u;
    }

    if ($updated) {
        # refresh the mailbox list
        foreach my $name (qw/local remote/) {
            @{$IMAP->{$name}}{qw/mailboxes delims/} = $IMAP->{$name}->{client}->list(q{"" "*"}, 'SUBSCRIBED');
        }
        my %mailboxes;
        $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});
        foreach my $mbx (keys %mailboxes) {
            die "Could not sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx);
        }
    }
}

# Syncronize subscription list
my @SUBSCRIPTIONS;
{
    my $sth_search = $DBH->prepare("SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?");
    my $sth_subscribe = $DBH->prepare("UPDATE mailboxes SET subscribed = ? WHERE idx = ?");

    my %mailboxes;
    $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});

    foreach my $mbx (keys %mailboxes) {
        if (subscribed_mbx('local',$mbx) xor subscribed_mbx('remote',$mbx)) {
            my ($subscribed,$unsubscribed) = subscribed_mbx('local',$mbx) ? ('local','remote') : ('remote','local');

            $sth_search->execute($mbx);
            my $row = $sth_search->fetch();
            die if defined $sth_search->fetch(); # sanity check

            if (defined $row) {
                my ($idx,$status) = @$row;
                if ($status) {
                    # $mbx was SUBSCRIBEd before, UNSUBSCRIBE it now
                    msg($subscribed, "Unsubscribe to mailbox $mbx");
                    $sth_subscribe->execute(0,$idx);
                    $IMAP->{$subscribed}->{client}->unsubscribe($mbx);
                    $DBH->commit();
                    $IMAP->{$subscribed}->{mailboxes}->{$mbx} =
                        grep {lc $_ ne lc '\Subscribed'} @{$IMAP->{$subscribed}->{mailboxes}->{$mbx} // []};
                }
                else {
                    # $mbx was UNSUBSCRIBEd before, SUBSCRIBE it now
                    msg($unsubscribed, "Subscribe to mailbox $mbx");
                    $sth_subscribe->execute(1,$idx);
                    $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
                    $DBH->commit();
                    $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= [];
                    push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed';
                }
            }
            else {
                # $mbx is unknown; assume the user wants to SUBSCRIBE
                msg($unsubscribed, "Subscribe to mailbox $mbx");
                $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
                $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= [];
                push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed';
            }
        }
        else {
            $sth_search->execute($mbx);
            my $row = $sth_search->fetch();
            die if defined $sth_search->fetch(); # sanity check

            if (defined $row) {
                my ($idx,$status) = @$row;
                unless (defined $status and $status != 0) {
                    my $subscribed = subscribed_mbx('local',$mbx) ? 1 : 0;
                    $sth_subscribe->execute($subscribed, $idx);
                    $DBH->commit();
                }
            }
        }
        push @SUBSCRIPTIONS, $mbx if subscribed_mbx('local', $mbx) and
                                     subscribed_mbx('remote',$mbx);
    }
}

# Clean database: remove mailboxes that no longer exist
{
    my $sth = $DBH->prepare("SELECT idx,mailbox,subscribed FROM mailboxes");
    my $sth_delete_mailboxes = $DBH->prepare("DELETE FROM mailboxes WHERE idx = ?");
    my $sth_delete_local     = $DBH->prepare("DELETE FROM local     WHERE idx = ?");
    my $sth_delete_remote    = $DBH->prepare("DELETE FROM remote    WHERE idx = ?");
    my $sth_delete_mapping   = $DBH->prepare("DELETE FROM mapping   WHERE idx = ?");

    my @idx;
    $sth->execute();
    while (defined (my $row = $sth->fetch)) {
        my ($idx,$mbx,$subscribed) = @$row;
        if (!exists_mbx('local',$mbx) and !exists_mbx('remote',$mbx)) {
            $_->execute($idx) foreach ($sth_delete_mapping,$sth_delete_local,$sth_delete_remote);
            $sth_delete_mailboxes->execute($idx) if
                !exists $IMAP->{local}->{mailboxes}->{$mbx} and
                !exists $IMAP->{remote}->{mailboxes}->{$mbx};
            $DBH->commit();
        }
    }
}



#############################################################################
# Synchronize messages
# Consider only the mailboxes in @ARGV, if the list is non-empty.

my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
undef $IMAP;


# Get all cached states from the database.
my $STH_GET_CACHE = $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
});
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 = ?
});

# Get the index associated with a mailbox.
my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx FROM mailboxes WHERE mailbox = ?});

# 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_NEWMAILBOX = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
my $STH_INSERT_LOCAL  = $DBH->prepare(q{INSERT INTO local  (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});

# 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 = ?});


# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
$STH_GET_CACHE->execute();
while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
    $lIMAP->set_cache($row->{mailbox},
        UIDVALIDITY   => $row->{lUIDVALIDITY},
        UIDNEXT       => $row->{lUIDNEXT},
        HIGHESTMODSEQ => ($CONFIG{check} ? 0 : $row->{lHIGHESTMODSEQ})
    );
    $rIMAP->set_cache($row->{mailbox},
        UIDVALIDITY   => $row->{rUIDVALIDITY},
        UIDNEXT       => $row->{rUIDNEXT},
        HIGHESTMODSEQ => ($CONFIG{check} ? 0 : $row->{rHIGHESTMODSEQ})
    );
}

# Download some missing UIDs.
sub fix_missing($$$@) {
    my $idx = shift;
    my $mailbox = shift;
    my $name = shift;
    my @set = @_;

    my $source = $name eq 'local' ? $lIMAP : $rIMAP;
    my $target = $name eq 'local' ? $rIMAP : $lIMAP;

    my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/;
    $source->fetch(compact_set(@set), "($attrs)", sub(%) {
        my %mail = @_;
        return unless exists $mail{RFC822}; # not for us

        my $from = first { defined $_ and @$_ } @{$mail{ENVELOPE}}[2,3,4];
        $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
        print STDERR "$name($mailbox): UID $mail{UID} from <$from> ($mail{INTERNALDATE})\n" unless $CONFIG{quiet};

        # don't bother checking for MULTIAPPEND, @set is probably rather small
        my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE});
        my ($uid) = $target->append($mailbox, @mail);

        my ($lUID, $rUID) = $name eq 'local' ? ($mail{UID}, $uid) : ($uid, $mail{UID});
        print STDERR "$name($mailbox): Adding mapping (lUID,rUID) = ($lUID,$rUID)\n";
        $STH_INSERT_MAPPING->execute($idx, $lUID, $rUID);
    });
}

# Check synchronization of a mailbox between the two servers (in a very crude way)
my @CHECKED;
sub check($$$$$) {
    my ($idx, $lVanished, $lList, $rVanished, $rList) = @_;

    my %lVanished = map {$_ => 1} @$lVanished;
    my %rVanished = map {$_ => 1} @$rVanished;

    $STH_GET_CACHE_BY_IDX->execute($idx);
    my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // die "Missing cache for index $idx";
    die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check
    my $mailbox = $cache->{mailbox};

    $STH_GET_MAPPING->execute($idx);
    my %missing = ( local => [], remote => [] );
    while (defined (my $row = $STH_GET_MAPPING->fetch())) {
        my ($lUID, $rUID) = @$row;
        if (defined $lList->{$lUID} and defined $rList->{$rUID}) {
            # both $lUID and $rUID are known
            if ($lList->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
                $rList->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) {
                # old stuff
                if ($lList->{$lUID}->[1] ne $rList->{$rUID}->[1]) {
                    warn "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Fixing...\n";
                    # keep it in the hash references so we fix it automatically
                }
                else {
                    # no conflict, remove it from the hashes
                    delete $lList->{$lUID};
                    delete $rList->{$rUID};
                }
            }
            else {
                # delete the old stuff
                delete $lList->{$lUID} if $lList->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ};
                delete $rList->{$rUID} if $rList->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ};
            }
        }
        elsif (!defined $lList->{$lUID} and !defined $rList->{$rUID}) {
            unless ($lVanished{$lUID} and $rVanished{$rUID}) {
                # will be deleted from the database later
                warn "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox\n";
                $lVanished{$lUID} = 1;
                $rVanished{$rUID} = 1;
            }
        }
        elsif (!defined $lList->{$lUID}) {
            unless ($lVanished{$lUID}) {
                warn "WARNING: local($mailbox): No match for remote UID $rUID. Downloading again...\n";
                push @{$missing{remote}}, $rUID;
                delete $rList->{$rUID};
            }
        }
        elsif (!defined $rList->{$rUID}) {
            unless ($rVanished{$rUID}) {
                warn "WARNING: remote($mailbox): No match for local UID $lUID. Downloading again...\n";
                push @{$missing{local}}, $lUID;
                delete $lList->{$lUID};
            }
        }
        $lList->{$lUID} = $lList->{$lUID}->[1] if defined $lList->{$lUID};
        $rList->{$rUID} = $rList->{$rUID}->[1] if defined $rList->{$rUID};
    }

    # we'll complain later for modified UIDs without an entry in the database

    @$lVanished = keys %lVanished;
    @$rVanished = keys %rVanished;
    push @CHECKED, $idx;
    return %missing;
}


# 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, %missing);

        my $check = ($CONFIG{check} and !grep { $idx == $_} @CHECKED) ? 1 : 0;
        ($lVanished, $lModified) = $lIMAP->pull_updates($check);
        ($rVanished, $rModified) = $rIMAP->pull_updates($check);
        %missing = check($idx, $lVanished, $lModified, $rVanished, $rModified) if $check;

        # repeat until we have nothing pending
        return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished or %missing;
        $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);
            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) {
                    warn "WARNING: remote($mailbox): No match for local vanished UID $lUID. Ignoring...\n";
                }
                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) {
                    warn "WARNING: local($mailbox): No match for remote vanished UID $rUID. Ignoring...\n";
                }
                elsif (!exists $lVanished{$lUID}) {
                    push @lToRemove, $lUID;
                }
            }

            $lIMAP->remove(@lToRemove) if @lToRemove;
            $rIMAP->remove(@rToRemove) if @rToRemove;

            # remove existing mappings
            foreach my $lUID (@$lVanished, @lToRemove) {
                my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
                die if $r > 1; # sanity check
                warn "WARNING: Can't delete (idx,lUID) = ($idx,$lUID) from the database\n" if $r == 0;
            }
        }

        # 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) {
                    warn "WARNING: remote($mailbox): No match for local updated UID $lUID. Downloading again...\n";
                    push @{$missing{local}}, $lUID;
                }
                elsif (defined (my $rFlags = $rModified->{$rUID})) {
                    unless ($lFlags eq $rFlags) {
                        my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags));
                        my $flags = join ' ', sort(keys %flags);
                        warn "WARNING: Conflicting FLAG update for lUID $lUID ($lFlags) and".
                             "rUID $rUID ($rFlags).  Setting both to the union ($flags).\n";
                        $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) {
                    warn "WARNING: local($mailbox): No match for remote updated UID $rUID. Downloading again...\n";
                    push @{$missing{remote}}, $rUID;
                }
                elsif (!exists $lModified->{$lUID}) {
                    # conflicts are taken care of above
                    $lToUpdate{$rFlags} //= [];
                    push @{$lToUpdate{$rFlags}}, $lUID;
                }
            }

            fix_missing($idx, $mailbox, 'local',  @{$missing{local}})  if @{$missing{local}  // []};
            fix_missing($idx, $mailbox, 'remote', @{$missing{remote}}) if @{$missing{remote} // []};

            while (my ($lFlags,$lUIDs) = each %lToUpdate) {
                $lIMAP->push_flag_updates($lFlags, @$lUIDs);
            }
            while (my ($rFlags,$rUIDs) = each %rToUpdate) {
                $rIMAP->push_flag_updates($rFlags, @$rUIDs);
            }
        }
    }
}


# Sync known and new messages
sub sync_messages($$) {
    my ($idx, $mailbox) = @_;

    my %mapping;
    foreach my $source (qw/remote local/) {
        my $target = $source eq 'local' ? $rIMAP : $lIMAP;
        my $multiappend;

        my @newmails;
        my $buffer = 0; # sum of the RFC822 sizes in @newmails

        my (@sUID, @tUID);

        # don't fetch again the messages we've just added
        my @ignore = $source eq 'local' ? keys %mapping : values %mapping;

        ($source eq 'local' ? $lIMAP : $rIMAP)->pull_new_messages(sub(%) {
            my %mail = @_;
            return unless exists $mail{RFC822}; # not for us

            my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE});
            push @sUID, $mail{UID};

            # use MULTIAPPEND if possible (RFC 3502) to save round-trips
            $multiappend //= !$target->incapable('MULTIAPPEND');

            if (!$multiappend) {
                my ($uid) = $target->append($mailbox, @mail);
                push @tUID, $uid;
            }
            else {
                # proceed by batch of 1MB to save roundtrips without blowing up the memory
                if (@newmails and $buffer + length($mail{RFC822}) > 1048576) {
                    push @tUID, $target->append($mailbox, @newmails);
                    @newmails = ();
                    $buffer = 0;
                }
                push @newmails, @mail;
                $buffer += length $mail{RFC822};
            }
        }, @ignore);
        push @tUID, $target->append($mailbox, @newmails) if @newmails;

        die unless $#sUID == $#tUID; # sanity check
        foreach my $k (0 .. $#sUID) {
            my ($lUID,$rUID) = $source eq 'local' ? ($sUID[$k],$tUID[$k]) : ($tUID[$k],$sUID[$k]);
            die if exists $mapping{$lUID}; # sanity check
            $mapping{$lUID} = $rUID;
        }
    }

    # new mailbox
    if (!defined $$idx) {
        my $subscribed = (grep { $_ eq $mailbox} @SUBSCRIPTIONS) ? 1 : 0;
        $STH_NEWMAILBOX->execute($mailbox, $subscribed);
        $STH_GET_INDEX->execute($mailbox);
        ($$idx) = $STH_GET_INDEX->fetchrow_array();
        die if !defined $$idx or defined $STH_GET_INDEX->fetchrow_arrayref(); # sanity check

        # there might be flag updates pending
        sync_known_messages($$idx, $mailbox);
        $STH_INSERT_LOCAL->execute($$idx,  $lIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
        $STH_INSERT_REMOTE->execute($$idx, $rIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
    }
    else {
        # update known mailbox
        sync_known_messages($$idx, $mailbox);
        $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
        $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
    }

    while (my ($lUID,$rUID) = each %mapping) {
        $STH_INSERT_MAPPING->execute($$idx, $lUID, $rUID);
    }
    $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
        }
    }
}


my ($mailbox, $idx);
while(1) {
    while(1) {
        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(@ARGV) // $rIMAP->next_dirty_mailbox(@ARGV) // 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

            $lIMAP->select($mailbox);
            $rIMAP->select($mailbox);

            # sync updates to known messages before fetching new messages
            if (defined $idx and sync_known_messages($idx, $mailbox)) {
                # get_cache is safe after pull_update
                $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $idx);
                $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $idx);
                $DBH->commit();
            }
            sync_messages(\$idx, $mailbox);
        }
    }
    # clean state!
    exit 0 if $CONFIG{oneshot} or $CONFIG{check};
    wait_notifications(900);
}

END { clean (); }