diff options
author | Guilhem Moulin <guilhem@fripost.org> | 2015-09-07 17:36:00 +0200 |
---|---|---|
committer | Guilhem Moulin <guilhem@fripost.org> | 2015-09-07 17:36:00 +0200 |
commit | ac3e4cf6300448e9c83b45db1b769d79c6df2e38 (patch) | |
tree | ef0f5952acb9e74255a4dfca1aa60b124a633ebf /imapsync | |
parent | adf204a2b54eb5fc47e97042012be0e407ac7e42 (diff) |
Rename ‘imapsync’ to ‘interimap’.
To avoid confusion with http://imapsync.lamiral.info .
Diffstat (limited to 'imapsync')
-rwxr-xr-x | imapsync | 1197 |
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(); -} |