From ac3e4cf6300448e9c83b45db1b769d79c6df2e38 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Sep 2015 17:36:00 +0200 Subject: =?UTF-8?q?Rename=20=E2=80=98imapsync=E2=80=99=20to=20=E2=80=98int?= =?UTF-8?q?erimap=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit To avoid confusion with http://imapsync.lamiral.info . --- interimap | 1197 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1197 insertions(+) create mode 100755 interimap (limited to 'interimap') diff --git a/interimap b/interimap new file mode 100755 index 0000000..6442054 --- /dev/null +++ b/interimap @@ -0,0 +1,1197 @@ +#!/usr/bin/perl -T + +#---------------------------------------------------------------------- +# Fast two-way synchronization program for QRESYNC-capable IMAP servers +# Copyright © 2015 Guilhem Moulin +# +# 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 . +#---------------------------------------------------------------------- + +use strict; +use warnings; + +our $VERSION = '0.1'; +my $NAME = 'interimap'; +use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat + bundling auto_version/; +use DBI (); +use List::Util 'first'; + +use lib 'lib'; +use Net::IMAP::InterIMAP qw/read_config compact_set $IMAP_text $IMAP_cond/; + +# Clean up PATH +$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin}; +delete @ENV{qw/IFS CDPATH ENV BASH_ENV/}; + +my %CONFIG; +sub usage(;$) { + my $rv = shift // 0; + if ($rv) { + print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n" + ."Try '$NAME --help' or consult the manpage for more information.\n"; + } + else { + print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n" + ." or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n" + ." or: $NAME [OPTIONS] --delete MAILBOX [..]\n" + ." or: $NAME [OPTIONS] --rename SOURCE DEST\n" + ."Consult the manpage for more information.\n"; + } + exit $rv; +} +usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h repair delete rename/); +usage(0) if $CONFIG{help}; +my $COMMAND = do { + my @command = grep {exists $CONFIG{$_}} qw/repair delete rename/; + usage(1) if $#command>0; + $command[0] +}; +usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND eq 'rename' and $#ARGV != 1); +@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive + + +my $CONF = read_config( delete $CONFIG{config} // $NAME + , [qw/_ local remote/] + , database => qr/\A(\P{Control}+)\z/ + , logfile => qr/\A(\/\P{Control}+)\z/ + , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ + , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/ + , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ + ); +my ($DBFILE, $LOCKFILE, $LOGGER_FD); + +{ + $DBFILE = $CONF->{_}->{database} if defined $CONF->{_}; + $DBFILE //= $CONF->{remote}->{host}.'.db' if defined $CONF->{remote}; + $DBFILE //= $CONF->{local}->{host}. '.db' if defined $CONF->{local}; + die "Missing option database" unless defined $DBFILE; + + unless ($DBFILE =~ /\A\//) { + my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME; + $dir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $dir"; + $dir = $1; + $DBFILE = $dir .'/'. $DBFILE; + unless (-d $dir) { + mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n"; + } + } + + $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r; + + if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) { + require 'POSIX.pm'; + require 'Time/HiRes.pm'; + open $LOGGER_FD, '>>', $CONF->{_}->{logfile} + or die "Can't open $CONF->{_}->{logfile}: $!\n"; + $LOGGER_FD->autoflush(1); + } + elsif ($CONFIG{debug}) { + $LOGGER_FD = \*STDERR; + } +} +my $DBH; + +# Clean after us +sub cleanup() { + logger(undef, "Cleaning up...") if $CONFIG{debug}; + unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE; + close $LOGGER_FD if defined $LOGGER_FD; + $DBH->disconnect() if defined $DBH; +} +$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 1; } foreach qw/INT TERM/; +$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 0; } foreach qw/HUP/; + + +############################################################################# +# Lock the database +{ + if (-f $LOCKFILE) { + open my $lock, '<', $LOCKFILE or die "Can't open $LOCKFILE: $!\n"; + my $pid = <$lock>; + close $lock; + chomp $pid; + my $msg = "LOCKFILE '$LOCKFILE' exists."; + $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/; + die $msg, "\n"; + } + + open my $lock, '>', $LOCKFILE or die "Can't open $LOCKFILE: $!\n"; + print $lock $$, "\n"; + close $lock; +} + + +############################################################################# +# Open the database and create tables + +$DBH = DBI::->connect("dbi:SQLite:dbname=$DBFILE", undef, undef, { + AutoCommit => 0, + RaiseError => 1, + sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not +}); +$DBH->do('PRAGMA foreign_keys = ON'); + + +{ + my @schema = ( + mailboxes => [ + q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT}, + q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE}, + q{subscribed BOOLEAN NOT NULL} + ], + local => [ + q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)}, + q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)}, + q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially + # one-to-one correspondence between local.idx and remote.idx + ], + remote => [ + q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)}, + q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)}, + q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially + # one-to-one correspondence between local.idx and remote.idx + ], + mapping => [ + q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)}, + q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)}, + q{rUID UNSIGNED INT NOT NULL CHECK (rUID > 0)}, + q{PRIMARY KEY (idx,lUID)}, + q{UNIQUE (idx,rUID)} + # also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT (except for interrupted syncs) + # mapping.idx must be found among local.idx (and remote.idx) + ], + ); + + # Invariants: + # * UIDVALIDITY never changes. + # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ < + # {local,remote}.HIGHESTMODSEQ have been propagated. + # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT + # (resp. <= remote.UIDNEXT). + # * Any idx in `local` must be present in `remote` and vice-versa. + # * Any idx in `mapping` must be present in `local` and `remote`. + while (@schema) { + my $table = shift @schema; + my $schema = shift @schema; + my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1}); + my $row = $sth->fetch(); + die if defined $sth->fetch(); # sanity check + unless (defined $row) { + $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")"); + $DBH->commit(); + } + } +} + +sub msg($@) { + my $name = shift; + return unless @_; + logger($name, @_) if defined $LOGGER_FD and $LOGGER_FD->fileno != fileno STDERR; + my $prefix = defined $name ? "$name: " : ''; + print STDERR $prefix, @_, "\n"; +} +sub logger($@) { + my $name = shift; + return unless @_ and defined $LOGGER_FD; + my $prefix = ''; + if ($LOGGER_FD->fileno != fileno STDERR) { + my ($s, $us) = Time::HiRes::gettimeofday(); + $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; + } + $prefix .= "$name: " if defined $name; + $LOGGER_FD->say($prefix, @_); +} +logger(undef, ">>> $NAME $VERSION"); + + +############################################################################# +# Connect to the local and remote IMAP servers + +my $IMAP; +foreach my $name (qw/local remote/) { + my %config = %{$CONF->{$name}}; + $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/; + $config{enable} = 'QRESYNC'; + $config{name} = $name; + $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD; + + $IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) }; + my $client = $IMAP->{$name}->{client}; + + die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED LIST-STATUS UIDPLUS/); + # XXX We should start by listing all mailboxes matching the user's LIST + # criterion, then issue "SET NOTIFY (mailboxes ... (...))". But this + # crashes the IMAP client: + # http://dovecot.org/pipermail/dovecot/2015-July/101473.html + #my $mailboxes = $client->list((uc $config{'subscribed-only'} eq 'TRUE' ? '(SUBSCRIBED)' : '' ) + # .$config{mailboxes}, 'SUBSCRIBED'); + # $client->notify('SELECTED', 'MAILBOXES ('.join(' ', keys %$mailboxes).')'); + # XXX NOTIFY doesn't work as expected for INBOX + # http://dovecot.org/pipermail/dovecot/2015-July/101514.html + #$client->notify(qw/SELECTED SUBSCRIBED/) if $CONFIG{watch}; + # XXX We shouldn't need to ask for STATUS responses here, and use + # NOTIFY's STATUS indicator instead. However Dovecot violates RFC + # 5464: http://dovecot.org/pipermail/dovecot/2015-July/101474.html + + my $list = '"" '; + my @params; + if (!defined $COMMAND or $COMMAND eq 'repair') { + $list = '('.uc($CONF->{_}->{'list-select-opts'}).') '.$list if defined $CONF->{_}->{'list-select-opts'}; + $list .= (defined $CONF->{_}->{'list-mailbox'} ? '('.$CONF->{_}->{'list-mailbox'}.')' : '*') unless @ARGV; + @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)'); + } + $list .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0]) + : ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV; + @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list($list, @params); +} + + +############################################################################## +# + +# Add a new mailbox to the database. +my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); + +# Get the index associated with a mailbox. +my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?}); + +# Ensure local and remote delimiter match +sub check_delim($) { + my $mbx = shift; + my ($lDelims, $rDelims) = map {$IMAP->{$_}->{delims}} qw/local remote/; + if (exists $lDelims->{$mbx} and exists $rDelims->{$mbx} and + ((defined $lDelims->{$mbx} xor defined $rDelims->{$mbx}) or + (defined $lDelims->{$mbx} and defined $rDelims->{$mbx} and $lDelims->{$mbx} ne $rDelims->{$mbx}))) { + my ($ld, $rd) = ($lDelims->{$mbx}, $rDelims->{$mbx}); + $ld =~ s/([\x22\x5C])/\\$1/g if defined $ld; + $rd =~ s/([\x22\x5C])/\\$1/g if defined $rd; + die "Error: Hierarchy delimiter for $mbx don't match: " + ."local \"". ($ld // '')."\", remote \"".($rd // '')."\"\n" + } + return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef; +} + +# Return true if $mailbox exists on $name +sub mbx_exists($$) { + my ($name, $mailbox) = @_; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0; +} + +# Return true if $mailbox is subscribed to on $name +sub mbx_subscribed($$) { + my ($name, $mailbox) = @_; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0; +} + + +############################################################################## +# Process --delete command +# +if (defined $COMMAND and $COMMAND eq 'delete') { + my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?}); + my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?}); + my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?}); + my $sth_delete_mapping = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ?}); + + foreach my $mailbox (@ARGV) { + $STH_GET_INDEX->execute($mailbox); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + # delete $mailbox on servers where $mailbox exists. note that + # there is a race condition where the mailbox could have + # appeared meanwhile + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + $IMAP->{$name}->{client}->delete($mailbox) if mbx_exists($name, $mailbox); + } + + if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + my $r1 = $sth_delete_mapping->execute($idx); + msg('database', "WARNING: `DELETE FROM mapping WHERE idx = $idx` failed") unless $r1; + my $r2 = $sth_delete_local->execute($idx); + msg('database', "WARNING: `DELETE FROM local WHERE idx = $idx` failed") unless $r2; + my $r3 = $sth_delete_remote->execute($idx); + msg('database', "WARNING: `DELETE FROM remote WHERE idx = $idx` failed") unless $r3; + my $r4 = $sth_delete_mailboxes->execute($idx); + msg('database', "WARNING: `DELETE FROM mailboxes WHERE idx = $idx` failed") unless $r4; + + $DBH->commit(); + msg('database', "Removed mailbox $mailbox") if $r4; + } + } + exit 0; +} + + +############################################################################## +# Process --rename command +# +elsif (defined $COMMAND and $COMMAND eq 'rename') { + my ($from, $to) = @ARGV; + + # get index of the original name + $STH_GET_INDEX->execute($from); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + # ensure the local and remote hierarchy delimiter match + my $delim = check_delim($from); + + # ensure the target name doesn't already exist on the servers. there + # is a race condition where the mailbox would be created before we + # issue the RENAME command, then the server would reply with a + # tagged NO response + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + if (mbx_exists($name, $to)) { + msg($name, "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); + exit 1; + } + } + + # ensure the target name doesn't already exist in the database + $STH_GET_INDEX->execute($to); + if (defined $STH_GET_INDEX->fetch() and + (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + msg('database', "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); + exit 1; + } + + + # rename $from to $to on servers where $from exists. again there is + # a race condition, but if $to has been created meanwhile the server + # will reply with a tagged NO response + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from); + } + + # rename from to $to in the database + if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + my $sth_rename_mailbox = $DBH->prepare(q{UPDATE mailboxes SET mailbox = ? WHERE idx = ?}); + my $r = $sth_rename_mailbox->execute($to, $idx); + msg('database', "WARNING: `UPDATE mailboxes SET mailbox = ".$DBH->quote($to)." WHERE idx = $idx` failed") unless $r; + + # for non-flat mailboxes, rename the children as well + if (defined $delim) { + my $prefix = $from.$delim; + my $sth_rename_children = $DBH->prepare(q{ + UPDATE mailboxes SET mailbox = ? || SUBSTR(mailbox,?) + WHERE SUBSTR(mailbox,1,?) = ? + }); + $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix); + } + + $DBH->commit(); + msg('database', "Renamed mailbox $from to $to") if $r; + } + exit 0; +} + + +############################################################################## +# Synchronize mailbox and subscription lists + +my @MAILBOXES; +{ + my %mailboxes; + $mailboxes{$_} = 1 foreach keys %{$IMAP->{local}->{mailboxes}}; + $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}}; + my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); + + foreach my $mailbox (keys %mailboxes) { + next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox =~ /$CONF->{_}->{'ignore-mailbox'}/o; + my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; + next unless $lExists or $rExists; + + my @attrs = do { + my %attrs = map {$_ => 1} (@{$IMAP->{local}->{mailboxes}->{$mailbox} // []}, + @{$IMAP->{remote}->{mailboxes}->{$mailbox} // []}); + keys %attrs; + }; + + check_delim($mailbox); # ensure that the delimiter match + push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs; + + $STH_GET_INDEX->execute($mailbox); + my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + if ($lExists and $rExists) { + # $mailbox exists on both sides + my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/; + if (defined $idx) { + if ($lSubscribed xor $rSubscribed) { + # mailbox is subscribed on only one server + if ($subscribed) { # unsubscribe + my $name = $lSubscribed ? 'local' : 'remote'; + $IMAP->{$name}->{client}->unsubscribe($mailbox); + } + else { # subscribe + my $name = $lSubscribed ? 'remote' : 'local'; + $IMAP->{$name}->{client}->subscribe($mailbox); + } + # toggle subscribtion in the database + $subscribed = $subscribed ? 0 : 1; + $sth_subscribe->execute($subscribed, $idx) or + msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $subscribed WHERE idx = $idx` failed"); + $DBH->commit(); + } + # $mailbox is either subscribed on both servers, or subscribed on both + elsif ($lSubscribed xor $subscribed) { + # update the database if needed + $sth_subscribe->execute($lSubscribed, $idx) or + msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $lSubscribed WHERE idx = $idx` failed"); + $DBH->commit(); + } + } + else { + # add new mailbox; subscribe on both servers if $mailbox is subscribed on one of them + my $subscribed = ($lSubscribed or $rSubscribed) ? 1 : 0; + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed and !$lSubscribed; + $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed and !$rSubscribed; + $DBH->commit(); + } + } + elsif ($lExists and !$rExists) { + # $mailbox is on 'local' only + if (defined $idx) { + msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); + exit 1; + } + my $subscribed = mbx_subscribed('local', $mailbox); + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{remote}->{client}->create($mailbox, 1); + $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed; + $DBH->commit(); + } + elsif (!$lExists and $rExists) { + # $mailbox is on 'remote' only + if (defined $idx) { + msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); + exit 1; + } + my $subscribed = mbx_subscribed('remote', $mailbox); + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{local}->{client}->create($mailbox, 1); + $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed; + $DBH->commit(); + } + } +} +my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/; +undef $IMAP; + + +############################################################################# +# Synchronize messages + +# Get all cached states from the database. +my $STH_GET_CACHE = $DBH->prepare(q{ + SELECT mailbox, m.idx AS idx, + l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ, + r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ + FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx +}); +my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{ + SELECT mailbox, + l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ, + r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ + FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx + WHERE m.idx = ? +}); + +# Find local/remote UID from the map. +my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?}); +my $STH_GET_REMOTE_UID = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? and lUID = ?}); + +# Delete a (idx,lUID,rUID) association. +# /!\ Don't commit before the messages have actually been EXPUNGEd on both sides! +my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?}); + +# Update the HIGHESTMODSEQ. +my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?}); +my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?}); + +# Update the HIGHESTMODSEQ and UIDNEXT. +my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); +my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); + +# Add a new mailbox. +my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)}); +my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)}); + +# Insert or retrieve a (idx,lUID,rUID) association. +my $STH_INSERT_MAPPING = $DBH->prepare(q{INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)}); +my $STH_GET_MAPPING = $DBH->prepare(q{SELECT lUID,rUID FROM mapping WHERE idx = ?}); + +# Get the list of interrupted mailbox syncs. +my $STH_LIST_INTERRUPTED = $DBH->prepare(q{ + SELECT mbx.idx, mailbox + FROM mailboxes mbx JOIN local l ON mbx.idx = l.idx JOIN remote r ON mbx.idx = r.idx JOIN mapping ON mbx.idx = mapping.idx + WHERE (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT) + GROUP BY mbx.idx +}); + +# For an interrupted mailbox sync, get the pairs (lUID,rUID) that have +# already been downloaded. +my $STH_GET_INTERRUPTED_BY_IDX = $DBH->prepare(q{ + SELECT lUID, rUID + FROM mapping m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx + WHERE m.idx = ? AND (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT) +}); + +# Count messages +my $STH_COUNT_MESSAGES = $DBH->prepare(q{SELECT COUNT(*) FROM mapping WHERE idx = ?}); + +# List last 1024 messages UIDs +my $STH_LASTUIDs_LOCAL = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? ORDER BY lUID DESC LIMIT 1024}); +my $STH_LASTUIDs_REMOTE = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? ORDER BY rUID DESC LIMIT 1024}); + + +# Download some missing UIDs from $source; returns the thew allocated UIDs +sub download_missing($$$@) { + my $idx = shift; + my $mailbox = shift; + my $source = shift; + my @set = @_; + my @uids; + + my $target = $source eq 'local' ? 'remote' : 'local'; + + my ($buff, $bufflen) = ([], 0); + undef $buff if ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND'); + + my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/; + ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) { + my $mail = shift; + return unless exists $mail->{RFC822}; # not for us + + my $uid = $mail->{UID}; + my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4]; + $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : ''; + msg(undef, "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet}; + + callback_new_message($idx, $mailbox, $source, $mail, \@uids, $buff, \$bufflen) + }); + push @uids, callback_new_message_flush($idx, $mailbox, $source, @$buff) if defined $buff and @$buff; + return @uids; +} + + +# Solve a flag update conflict (by taking the union of the two flag lists). +sub flag_conflict($$$$$) { + my ($mailbox, $lUID, $lFlags, $rUID, $rFlags) = @_; + + my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags)); + my $flags = join ' ', sort(keys %flags); + msg(undef, "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ". + "and remote UID $rUID ($rFlags). Setting both to the union ($flags)."); + + return $flags +} + + +# Delete a mapping ($idx, $lUID) +sub delete_mapping($$) { + my ($idx, $lUID) = @_; + my $r = $STH_DELETE_MAPPING->execute($idx, $lUID); + die if $r > 1; # sanity check + msg('database', "WARNING: Can't delete (idx,lUID) = ($idx,$lUID)") if $r == 0; +} + + +# Create a sample (sequence numbers, UIDs) to use as Message Sequence +# Match Data for the QRESYNC parameter to the SELECT command. +# QRESYNC [RFC7162] doesn't force the server to remember the MODSEQs of +# EXPUNGEd messages. By passing a sample of known sequence numbers/UIDs +# we let the server know that the messages have been EXPUNGEd [RFC7162, +# section 3.2.5.2]. +# The UID set is the largest set of higest UIDs with at most 1024 UIDs, +# of length (after compacting) at most 64. +# The reason why we sample with the highest UIDs is that lowest UIDs are +# less likely to be deleted. +sub sample($$$) { + my ($idx, $count, $sth) = @_; + return unless $count > 0; + + my ($n, $uids, $min, $max); + $sth->execute($idx); + while (defined (my $row = $sth->fetchrow_arrayref())) { + my $k = $row->[0]; + if (!defined $min and !defined $max) { + $n = 0; + $min = $max = $k; + } + elsif ($k == $min - 1) { + $min--; + } + else { + $n += $max - $min + 1; + $uids = ($min == $max ? $min : "$min:$max") + .(defined $uids ? ','.$uids : ''); + $min = $max = $k; + if (length($uids) > 64) { + $sth->finish(); # done with the statement + last; + } + } + } + if (!defined $uids or length($uids) <= 64) { + $n += $max - $min + 1; + $uids = ($min == $max ? $min : "$min:$max") + .(defined $uids ? ','.$uids : ''); + } + return ( ($count - $n + 1).':'.$count, $uids ); +} + + +# Issue a SELECT command with the given $mailbox. +sub select_mbx($$) { + my ($idx, $mailbox) = @_; + + $STH_COUNT_MESSAGES->execute($idx); + my ($count) = $STH_COUNT_MESSAGES->fetchrow_array(); + die if defined $STH_COUNT_MESSAGES->fetch(); # sanity check + + $lIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_LOCAL)); + $rIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_REMOTE)); +} + + +# Check and repair synchronization of a mailbox between the two servers +# (in a very crude way, by downloading all existing UID with their flags) +sub repair($) { + my $mailbox = shift; + + $STH_GET_INDEX->execute($mailbox); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + return unless defined $idx; # not in the database + select_mbx($idx, $mailbox); + + $STH_GET_CACHE_BY_IDX->execute($idx); + my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // return; # no cache + die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check + + # get all existing UID with their flags + my ($lVanished, $lModified) = $lIMAP->pull_updates(1); + my ($rVanished, $rModified) = $rIMAP->pull_updates(1); + + my %lVanished = map {$_ => 1} @$lVanished; + my %rVanished = map {$_ => 1} @$rVanished; + + my (@lToRemove, %lToUpdate, @lMissing); + my (@rToRemove, %rToUpdate, @rMissing); + my @delete_mapping; + + # process each pair ($lUID,$rUID) found in the mapping table, and + # compare with the result from the IMAP servers to detect anomalies + + $STH_GET_MAPPING->execute($idx); + while (defined (my $row = $STH_GET_MAPPING->fetch())) { + my ($lUID, $rUID) = @$row; + if (defined $lModified->{$lUID} and defined $rModified->{$rUID}) { + # both $lUID and $rUID are known; see sync_known_messages + # for the sync algorithm + my ($lFlags, $rFlags) = ($lModified->{$lUID}->[1], $rModified->{$rUID}->[1]); + if ($lFlags eq $rFlags) { + # no conflict + } + elsif ($lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and + $rModified->{$rUID}->[0] > $cache->{rHIGHESTMODSEQ}) { + # set $lUID to $rFlags + $lToUpdate{$rFlags} //= []; + push @{$lToUpdate{$rFlags}}, $lUID; + } + elsif ($lModified->{$lUID}->[0] > $cache->{lHIGHESTMODSEQ} and + $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) { + # set $rUID to $lFlags + $rToUpdate{$lFlags} //= []; + push @{$rToUpdate{$lFlags}}, $rUID; + } + else { + # conflict + msg(undef, "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.") + if $lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and + $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}; + # set both $lUID and $rUID to the union of $lFlags and $rFlags + my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags); + $lToUpdate{$flags} //= []; + push @{$lToUpdate{$flags}}, $lUID; + $rToUpdate{$flags} //= []; + push @{$rToUpdate{$flags}}, $rUID; + } + } + elsif (!defined $lModified->{$lUID} and !defined $rModified->{$rUID}) { + unless ($lVanished{$lUID} and $rVanished{$rUID}) { + msg(undef, "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing."); + push @delete_mapping, $lUID; + } + } + elsif (!defined $lModified->{$lUID}) { + push @delete_mapping, $lUID; + if ($lVanished{$lUID}) { + push @rToRemove, $rUID; + } else { + msg("local($mailbox)", "WARNING: UID $lUID disappeared. Downloading remote UID $rUID again."); + push @rMissing, $rUID; + } + } + elsif (!defined $rModified->{$rUID}) { + push @delete_mapping, $lUID; + if ($rVanished{$rUID}) { + push @lToRemove, $lUID; + } else { + msg("remote($mailbox)", "WARNING: UID $rUID disappeared. Downloading local UID $lUID again."); + push @lMissing, $lUID; + } + } + + delete $lModified->{$lUID}; + delete $lVanished{$lUID}; + delete $rModified->{$rUID}; + delete $rVanished{$rUID}; + } + + # remove messages on the IMAP side; will increase HIGHESTMODSEQ + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@rToRemove) if @rToRemove; + + # remove entries in the table + delete_mapping($idx, $_) foreach @delete_mapping; + $DBH->commit() if @delete_mapping; + + # push flag updates; will increase HIGHESTMODSEQ + while (my ($lFlags,$lUIDs) = each %lToUpdate) { + $lIMAP->push_flag_updates($lFlags, @$lUIDs); + } + while (my ($rFlags,$rUIDs) = each %rToUpdate) { + $rIMAP->push_flag_updates($rFlags, @$rUIDs); + } + + + # Process UID found in IMAP but not in the mapping table. + my @lDunno = keys %lVanished; + my @rDunno = keys %rVanished; + msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " + .compact_set(@lDunno).". Ignoring.") if @lDunno; + msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " + .compact_set(@rDunno).". Ignoring.") if @rDunno; + + foreach my $lUID (keys %$lModified) { + msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Downloading again."); + push @lMissing, $lUID; + } + foreach my $rUID (keys %$rModified) { + msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Downloading again."); + push @rMissing, $rUID; + } + + # download missing UIDs; will increase UIDNEXT and HIGHESTMODSEQ + my @rIgnore = download_missing($idx, $mailbox, 'local', @lMissing) if @lMissing; + my @lIgnore = download_missing($idx, $mailbox, 'remote', @rMissing) if @rMissing; + + # download new messages; this will also update UIDNEXT and HIGHESTMODSEQ in the database + sync_messages($idx, $mailbox, \@lIgnore, \@rIgnore); +} + + +# Sync known messages. Since pull_updates is the last method call on +# $lIMAP and $rIMAP, it is safe to call get_cache on either object after +# this function, in order to update the HIGHESTMODSEQ. +# Return true if an update was detected, and false otherwise +sub sync_known_messages($$) { + my ($idx, $mailbox) = @_; + my $update = 0; + + # loop since processing might produce VANISHED or unsollicited FETCH responses + while (1) { + my ($lVanished, $lModified, $rVanished, $rModified); + + ($lVanished, $lModified) = $lIMAP->pull_updates(); + ($rVanished, $rModified) = $rIMAP->pull_updates(); + + # repeat until we have nothing pending + return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished; + $update = 1; + + # process VANISHED messages + # /!\ this might modify the VANISHED or MODIFIED cache! + if (@$lVanished or @$rVanished) { + my %lVanished = map {$_ => 1} @$lVanished; + my %rVanished = map {$_ => 1} @$rVanished; + + # For each vanished UID, get the corresponding one on the + # other side (from the DB); consider it as to be removed if + # it hasn't been removed already. + + my (@lToRemove, @rToRemove, @lDunno, @rDunno); + foreach my $lUID (@$lVanished) { + $STH_GET_REMOTE_UID->execute($idx, $lUID); + my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); + die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check + if (!defined $rUID) { + push @lDunno, $lUID; + } + elsif (!exists $rVanished{$rUID}) { + push @rToRemove, $rUID; + } + } + foreach my $rUID (@$rVanished) { + $STH_GET_LOCAL_UID->execute($idx, $rUID); + my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); + die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check + if (!defined $lUID) { + push @rDunno, $rUID; + } + elsif (!exists $lVanished{$lUID}) { + push @lToRemove, $lUID; + } + } + + msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " + .compact_set(@lDunno).". Ignoring.") if @lDunno; + msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " + .compact_set(@rDunno).". Ignoring.") if @rDunno; + + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@rToRemove) if @rToRemove; + + # remove existing mappings + foreach my $lUID (@$lVanished, @lToRemove) { + delete_mapping($idx, $lUID); + } + } + + # process FLAG updates + # /!\ this might modify the VANISHED or MODIFIED cache! + if (%$lModified or %$rModified) { + my (%lToUpdate, %rToUpdate); + + # Take flags updates on both sides, and get the + # corresponding UIDs on the other side (from the DB). + # If it wasn't modified there, make it such; if it was + # modified with the same flags list, ignore that message; + # otherwise there is a conflict, and take the union. + # + # Group by flags in order to limit the number of round + # trips. + + while (my ($lUID,$lFlags) = each %$lModified) { + $STH_GET_REMOTE_UID->execute($idx, $lUID); + my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); + die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check + if (!defined $rUID) { + msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Try '--repair'."); + } + elsif (defined (my $rFlags = $rModified->{$rUID})) { + unless ($lFlags eq $rFlags) { + my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags); + $lToUpdate{$flags} //= []; + push @{$lToUpdate{$flags}}, $lUID; + $rToUpdate{$flags} //= []; + push @{$rToUpdate{$flags}}, $rUID; + } + } + else { + $rToUpdate{$lFlags} //= []; + push @{$rToUpdate{$lFlags}}, $rUID; + } + } + while (my ($rUID,$rFlags) = each %$rModified) { + $STH_GET_LOCAL_UID->execute($idx, $rUID); + my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); + die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check + if (!defined $lUID) { + msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Try '--repair'."); + } + elsif (!exists $lModified->{$lUID}) { + # conflicts are taken care of above + $lToUpdate{$rFlags} //= []; + push @{$lToUpdate{$rFlags}}, $lUID; + } + } + + while (my ($lFlags,$lUIDs) = each %lToUpdate) { + $lIMAP->push_flag_updates($lFlags, @$lUIDs); + } + while (my ($rFlags,$rUIDs) = each %rToUpdate) { + $rIMAP->push_flag_updates($rFlags, @$rUIDs); + } + } + } +} + + +# The callback to use when FETCHing new messages from $name to add it to +# the other one. +# If defined, the array reference $UIDs will be fed with the newly added +# UIDs. +# If defined, $buff contains the list of messages to be appended with +# MULTIAPPEND. In that case callback_new_message_flush should be called +# after the FETCH. +sub callback_new_message($$$$;$$$) { + my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_; + return unless exists $mail->{RFC822}; # not for us + + my $length = length $mail->{RFC822}; + if ($length == 0) { + msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})"); + return; + } + + my @UIDs; + unless (defined $buff) { + @UIDs = callback_new_message_flush($idx, $mailbox, $name, $mail); + } + else { + # use MULTIAPPEND (RFC 3502) + # proceed by batches of 1MB to save roundtrips without blowing up the memory + if (@$buff and $$bufflen + $length > 1048576) { + @UIDs = callback_new_message_flush($idx, $mailbox, $name, @$buff); + @$buff = (); + $$bufflen = 0; + } + push @$buff, $mail; + $$bufflen += $length; + } + push @$UIDs, @UIDs if defined $UIDs; +} + + +# Add the given @messages (multiple messages are only allowed for +# MULTIAPPEND-capable servers) from $name to the other server. +# Returns the list of newly allocated UIDs. +sub callback_new_message_flush($$$@) { + my ($idx, $mailbox, $name, @messages) = @_; + + my $imap = $name eq 'local' ? $rIMAP : $lIMAP; # target client + my @sUID = map {$_->{UID}} @messages; + my @tUID = $imap->append($mailbox, @messages); + die unless $#sUID == $#tUID; # sanity check + + my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID); + for (my $k=0; $k<=$#messages; $k++) { + logger(undef, "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox") + if $CONFIG{debug}; + $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]); + } + $DBH->commit(); # commit only once per batch + + return @tUID; +} + + +# Sync both known and new messages +# If the array references $lIgnore and $rIgnore are not empty, skip +# the given UIDs. +sub sync_messages($$;$$) { + my ($idx, $mailbox, $lIgnore, $rIgnore) = @_; + + my %ignore = (local => ($lIgnore // []), remote => ($rIgnore // [])); + my $loop; + do { + # get new messages from $source (except @{$ignore{$source}}) and APPEND them to $target + foreach my $source (qw/remote local/) { # pull remote mails first + my $target = $source eq 'remote' ? 'local' : 'remote'; + my $buff = [] unless ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND'); + my $bufflen = 0; + my @tUIDs; + + ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages(sub($) { + callback_new_message($idx, $mailbox, $source, shift, \@tUIDs, $buff, \$bufflen) + }, @{$ignore{$source}}); + + push @tUIDs, callback_new_message_flush($idx, $mailbox, $source, @$buff) + if defined $buff and @$buff; + push @{$ignore{$target}}, @tUIDs; + + $loop = @tUIDs ? 1 : 0; + } + # since $source modifies $target's UIDNEXT upon new mails, we + # need to check again the first $source (remote) whenever the + # last one (local) added new messages to it + } + while ($loop); + + # both local and remote UIDNEXT are now up to date; proceed with + # pending flag updates and vanished messages + sync_known_messages($idx, $mailbox); + + # don't store the new UIDNEXTs before to avoid downloading these + # mails again in the event of a crash + $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $idx) or + msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox"); + $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $idx) or + msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox"); + $DBH->commit(); +} + + +# Wait up to $timout seconds for notifications on either IMAP server. +# Then issue a NOOP so the connection doesn't terminate for inactivity. +sub wait_notifications(;$) { + my $timeout = shift // 300; + + while ($timeout > 0) { + my $r1 = $lIMAP->slurp(); + my $r2 = $rIMAP->slurp(); + last if $r1 or $r2; # got update! + + sleep 1; + if (--$timeout == 0) { + $lIMAP->noop(); + $rIMAP->noop(); + # might have got updates so exit the loop + } + } +} + + +############################################################################# +# Resume interrupted mailbox syncs (before initializing the cache). +# +my ($MAILBOX, $IDX); +$STH_LIST_INTERRUPTED->execute(); +while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { + next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailbox + ($IDX, $MAILBOX) = @$row; + msg(undef, "Resuming interrupted sync for $MAILBOX"); + + my %lUIDs; + $STH_GET_INTERRUPTED_BY_IDX->execute($IDX); + while (defined (my $row = $STH_GET_INTERRUPTED_BY_IDX->fetchrow_arrayref())) { + $lUIDs{$row->[0]} = $row->[1]; # pair ($lUID, $rUID) + } + die unless %lUIDs; # sanity check + + $lIMAP->select($MAILBOX); + $rIMAP->select($MAILBOX); + + # FETCH all messages with their FLAGS to detect messages that have + # vanished meanwhile, or for which there was a flag update. + + my (%lList, %rList); # The lists of existing local and remote UIDs + my $attrs = '('.join(' ', qw/MODSEQ FLAGS/).')'; + $lIMAP->fetch(compact_set(keys %lUIDs), $attrs, sub($){ $lList{shift->{UID}} = 1 }); + $rIMAP->fetch(compact_set(values %lUIDs), $attrs, sub($){ $rList{shift->{UID}} = 1 }); + + my (@lToRemove, @rToRemove); + while (my ($lUID,$rUID) = each %lUIDs) { + next if $lList{$lUID} and $rList{$rUID}; # exists on both + push @lToRemove, $lUID if $lList{$lUID}; + push @rToRemove, $rUID if $rList{$rUID}; + + delete_mapping($IDX, $lUID); + } + + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@rToRemove) if @rToRemove; + $DBH->commit() if @lToRemove or @rToRemove; # /!\ commit *after* remove_message! + + # ignore deleted messages + delete @lList{@lToRemove}; + delete @rList{@rToRemove}; + + # Resume the sync, but skip messages that have already been + # downloaded. Flag updates will be processed automatically since + # the _MODIFIED internal cache has been initialized with all our + # UIDs. (Since there is no reliable HIGHESTMODSEQ, any flag + # difference is treated as a conflict.) + sync_messages($IDX, $MAILBOX, [keys %lList], [keys %rList]); +} + + +############################################################################# +# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness. +# +my %KNOWN_INDEXES; +$STH_GET_CACHE->execute(); +while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { + next unless grep {$row->{mailbox} eq $_} @MAILBOXES; + $lIMAP->set_cache($row->{mailbox}, + UIDVALIDITY => $row->{lUIDVALIDITY}, + UIDNEXT => $row->{lUIDNEXT}, + HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ} + ); + $rIMAP->set_cache($row->{mailbox}, + UIDVALIDITY => $row->{rUIDVALIDITY}, + UIDNEXT => $row->{rUIDNEXT}, + HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ} + ); + $KNOWN_INDEXES{$row->{idx}} = 1; +} + +if (defined $COMMAND and $COMMAND eq 'repair') { + repair($_) foreach @MAILBOXES; + exit 0; +} + + +while(1) { + while(@MAILBOXES) { + my $cache; + my $update = 0; + if (defined $MAILBOX and ($lIMAP->is_dirty($MAILBOX) or $rIMAP->is_dirty($MAILBOX))) { + # $MAILBOX is dirty on either the local or remote mailbox + sync_messages($IDX, $MAILBOX); + } + else { + $MAILBOX = $lIMAP->next_dirty_mailbox(@MAILBOXES) // $rIMAP->next_dirty_mailbox(@MAILBOXES) // last; + $MAILBOX = 'INBOX' if uc $MAILBOX eq 'INBOX'; # INBOX is case insensitive + + $STH_GET_INDEX->execute($MAILBOX); + ($IDX) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + die unless defined $IDX; # sanity check; + + select_mbx($IDX, $MAILBOX); + + if (!$KNOWN_INDEXES{$IDX}) { + $STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX)); + $STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX)); + + # no need to commit before the first mapping (lUID,rUID) + $KNOWN_INDEXES{$IDX} = 1; + } + elsif (sync_known_messages($IDX, $MAILBOX)) { + # sync updates to known messages before fetching new messages + # get_cache is safe after pull_update + $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or + msg('database', "WARNING: Can't update local HIGHESTMODSEQ for $MAILBOX"); + $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or + msg('database', "WARNING: Can't update remote HIGHESTMODSEQ for $MAILBOX"); + $DBH->commit(); + } + sync_messages($IDX, $MAILBOX); + } + } + # clean state! + exit 0 unless defined $COMMAND and $COMMAND eq 'watch'; + wait_notifications(900); +} + +END { + $_->logout() foreach grep defined, ($lIMAP, $rIMAP); + cleanup(); +} -- cgit v1.2.3