#!/usr/bin/perl -T #---------------------------------------------------------------------- # IMAP-to-IMAP synchronization program for QRESYNC-capable 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 = '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 rUID FROM mapping WHERE idx = ? ORDER BY rUID DESC LIMIT 1024}); my $STH_LASTUIDs_REMOTE = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? ORDER BY lUID 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(); }