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