First attempt.

1 files changed, 796 insertions, 0 deletions

diff --git a/imapsync b/imapsync
new file mode 100755
index 0000000..eb8f652
--- /dev/null
+++ b/imapsync
@@ -0,0 +1,796 @@
+#!/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 POSIX 'strftime';
+
+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 quiet|q oneshot|1/);
+usage(0) if $CONFIG{help};
+
+
+my $CONFFILE = 'sync.ini';
+my $CACHEDIR = './imapsync.cache'; # XXX use a config option
+my $DBFILE = "$CACHEDIR/imap.guilhem.org.db";
+my $LOCKFILE = "$CACHEDIR/.imap.guilhem.org.lck";
+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 (!-d $CACHEDIR) {
+        mkdir $CACHEDIR, 0700 or die "Cannot mkdir $CACHEDIR: $!\n";
+    }
+    elsif (-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 = strftime "%b %e %H:%M:%S", localtime;
+    $prefix .= " $name" if defined $name;
+    $prefix .= ': ';
+    print STDERR $prefix, @_, "\n";
+}
+
+
+#############################################################################
+# Connect to the local and remote IMAP servers
+
+foreach my $name (qw/local remote/) {
+    my %config = Net::IMAP::Sync::read_config($CONFFILE, $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';
+            }
+        }
+        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
+});
+
+# 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("SELECT lUID FROM mapping WHERE idx = ? and rUID = ?");
+my $STH_GET_REMOTE_UID = $DBH->prepare("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("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 a (idx,lUID,rUID) association.
+my $STH_INSERT_MAPPING = $DBH->prepare("INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)");
+
+
+# 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 => $row->{lHIGHESTMODSEQ}
+    );
+    $rIMAP->set_cache($row->{mailbox},
+        UIDVALIDITY   => $row->{rUIDVALIDITY},
+        UIDNEXT       => $row->{rUIDNEXT},
+        HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
+    );
+}
+
+
+# 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 = shift;
+    my $update = 0;
+
+    # loop since processing might produce VANISHED or unsollicited FETCH responses
+    while (1) {
+        my ($lVanished, $lModified) = $lIMAP->pull_updates();
+        my ($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);
+            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: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\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: Couldn't find a matching lUID for (idx,rUID) = ($idx,$rUID)\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: Couldn't delete (idx,lUID) pair ($idx,$lUID)\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: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+                }
+                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: Couldn't find a matching rUID for (idx,rUID) = ($idx,$rUID)\n";
+                }
+                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);
+            }
+        }
+    }
+}
+
+
+# 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);
+        $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);
+        $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 for notifications on either IMAP server, up to $timout.  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();
+        }
+    }
+}
+
+
+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)) {
+                # 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};
+    wait_notifications(900);
+}
+
+END { clean (); }