aboutsummaryrefslogtreecommitdiffstats
path: root/imapsync
diff options
context:
space:
mode:
Diffstat (limited to 'imapsync')
-rwxr-xr-ximapsync796
1 files changed, 796 insertions, 0 deletions
diff --git a/imapsync b/imapsync
new file mode 100755
index 0000000..eb8f652
--- /dev/null
+++ b/imapsync
@@ -0,0 +1,796 @@
+#!/usr/bin/perl -T
+
+#----------------------------------------------------------------------
+# A minimal IMAP4 client for QRESYNC-capable servers
+# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#----------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+our $VERSION = '0.1';
+my $NAME = 'imapsync';
+use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
+ bundling auto_version/;
+
+use List::Util 'first';
+use DBI ();
+use POSIX 'strftime';
+
+use lib 'lib';
+use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/;
+
+# Clean up PATH
+$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin};
+delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
+
+my %CONFIG;
+sub usage(;$) {
+ my $rv = shift // 0;
+ print STDERR "TODO $NAME usage\n";
+ exit $rv;
+}
+usage(1) unless GetOptions(\%CONFIG, qw/debug help|h quiet|q oneshot|1/);
+usage(0) if $CONFIG{help};
+
+
+my $CONFFILE = 'sync.ini';
+my $CACHEDIR = './imapsync.cache'; # XXX use a config option
+my $DBFILE = "$CACHEDIR/imap.guilhem.org.db";
+my $LOCKFILE = "$CACHEDIR/.imap.guilhem.org.lck";
+my ($DBH, $IMAP);
+
+
+# Clean after us
+sub clean() {
+ print STDERR "Cleaning...\n" if $CONFIG{debug};
+ unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
+ undef $_ foreach grep defined, map {$IMAP->{$_}->{client}} keys %$IMAP;
+ $DBH->disconnect() if defined $DBH;
+}
+$SIG{$_} = sub { clean(); die "$!\n"; } foreach qw/INT TERM/;
+
+
+#############################################################################
+# Lock the database
+{
+ if (!-d $CACHEDIR) {
+ mkdir $CACHEDIR, 0700 or die "Cannot mkdir $CACHEDIR: $!\n";
+ }
+ elsif (-f $LOCKFILE) {
+ open my $lock, '<', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
+ my $pid = <$lock>;
+ close $lock;
+ chomp $pid;
+ my $msg = "LOCKFILE '$LOCKFILE' exists.";
+ $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/;
+ die $msg, "\n";
+ }
+
+ open my $lock, '>', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
+ print $lock $$, "\n";
+ close $lock;
+}
+
+
+#############################################################################
+# Open the database and create tables
+
+$DBH = DBI::->connect("dbi:SQLite:dbname=$DBFILE", undef, undef, {
+ AutoCommit => 0,
+ RaiseError => 1,
+ sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not
+});
+$DBH->do('PRAGMA foreign_keys = ON');
+
+
+{
+ my @schema = (
+ mailboxes => [
+ q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
+ q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE},
+ q{subscribed BOOLEAN NOT NULL}
+ ],
+ local => [
+ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
+ q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
+ q{UIDNEXT UNSIGNED INT NOT NULL CHECK (UIDNEXT > 0)},
+ q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)}
+ # one-to-one correspondence between local.idx and remote.idx
+ ],
+ remote => [
+ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
+ q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
+ q{UIDNEXT UNSIGNED INT NOT NULL CHECK (UIDNEXT > 0)},
+ q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)}
+ # one-to-one correspondence between local.idx and remote.idx
+ ],
+ mapping => [
+ q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)},
+ q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)},
+ q{rUID UNSIGNED INT NOT NULL CHECK (rUID > 0)},
+ q{PRIMARY KEY (idx,lUID)},
+ q{UNIQUE (idx,rUID)}
+ # also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT
+ # mapping.idx must be found among local.idx (and remote.idx)
+ ],
+ );
+
+ # Invariants:
+ # * UIDVALIDITY never changes.
+ # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ <
+ # {local,remote}.HIGHESTMODSEQ have been propagated.
+ # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT
+ # (resp. <= remote.UIDNEXT).
+ # * Any idx in `local` must be present in `remote` and vice-versa.
+ # * Any idx in `mapping` must be present in `local` and `remote`.
+ while (@schema) {
+ my $table = shift @schema;
+ my $schema = shift @schema;
+ my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1});
+ my $row = $sth->fetch();
+ die if defined $sth->fetch(); # sanity check
+ unless (defined $row) {
+ $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")");
+ $DBH->commit();
+ }
+ }
+}
+
+sub msg($@) {
+ my $name = shift;
+ return unless @_;
+ my $prefix = strftime "%b %e %H:%M:%S", localtime;
+ $prefix .= " $name" if defined $name;
+ $prefix .= ': ';
+ print STDERR $prefix, @_, "\n";
+}
+
+
+#############################################################################
+# Connect to the local and remote IMAP servers
+
+foreach my $name (qw/local remote/) {
+ my %config = Net::IMAP::Sync::read_config($CONFFILE, $name);
+ $config{$_} = $CONFIG{$_} foreach keys %CONFIG;
+ $config{enable} = 'QRESYNC';
+ $config{name} = $name;
+
+ $IMAP->{$name} = { client => Net::IMAP::Sync::->new(%config) };
+ my $client = $IMAP->{$name}->{client};
+
+ die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED LIST-STATUS UIDPLUS/);
+ # XXX We should start by listing all mailboxes matching the user's LIST
+ # criterion, then issue "SET NOTIFY (mailboxes ... (...))". But this
+ # crashes the IMAP client:
+ # http://dovecot.org/pipermail/dovecot/2015-July/101473.html
+ #my $mailboxes = $client->list((uc $config{'subscribed-only'} eq 'TRUE' ? '(SUBSCRIBED)' : '' )
+ # .$config{mailboxes}, 'SUBSCRIBED');
+ # $client->notify('SELECTED', 'MAILBOXES ('.join(' ', keys %$mailboxes).')');
+ $client->notify(qw/SELECTED SUBSCRIBED/) unless $CONFIG{oneshot};
+ # XXX We shouldn't need to ask for STATUS responses here, and use
+ # NOTIFY's STATUS indicator instead. However Dovecot violates RFC
+ # 5464: http://dovecot.org/pipermail/dovecot/2015-July/101474.html
+ @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list(q{"" "*"}, 'SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)' );
+}
+
+
+#############################################################################
+# Synchronize mailbox and subscription lists
+
+sub make_tree(%);
+sub print_tree($%);
+sub mv_tree($$$%);
+sub sync_tree($$%);
+
+# Take a hash of delimiters, and recursively build a tree out of it.
+# For instance ( a => "/", b => "/", "a/c" => ".", "a/c.d" => "/", "a/d" => ".")
+# is transformed into the hash reference
+# { b => {},
+# { a => { "/c" => { ".d" => {} } }
+# , "/d" => {}
+# }
+# }
+sub make_tree(%) {
+ my %delims = @_;
+ my @list = sort {length($a) <=> length($b)} keys %delims;
+
+ my %tree;
+ foreach my $x (@list) {
+ next unless exists $delims{$x}; # already a children of something
+ my %children;
+ foreach (keys %delims) {
+ next unless defined $delims{$x} and s/\A\Q$x$delims{$x}\E/$delims{$x}/;
+ $children{$_} = delete $delims{"$x$_"};
+ }
+ delete $delims{$x};
+ $tree{$x} = make_tree(%children);
+ }
+ return \%tree;
+}
+#sub print_tree($%) {
+# my $indent = shift;
+# my %tree = @_;
+# while (my ($root, $children) = each %tree) {
+# print " "x$indent, '|- ', $root, "\n";
+# print_tree($indent+2, %$children);
+# }
+#}
+
+# Retrun true if $mailbox exists for $name that is, if doesn't have the
+# '\NonExistent' flag set.
+sub exists_mbx($$) {
+ my $name = shift;
+ my $mailbox = shift;
+ my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox};
+ return (defined $flags and !grep {lc $_ eq lc '\NonExistent'} @$flags) ? 1 : 0;
+}
+# Retrun true if $mailbox is subscribed for $name.
+sub subscribed_mbx($$) {
+ my $name = shift;
+ my $mailbox = shift;
+ my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox};
+ return (defined $flags and grep {lc $_ eq lc '\Subscribed'} @$flags) ? 1 : 0;
+}
+
+# Rename a root recursively in a tree
+sub mv_tree($$$%) {
+ my ($mailboxes, $mbx, $mbx2, %children) = @_;
+ $mailboxes->{$mbx2} = delete $mailboxes->{$mbx};
+ while (my ($root, $children) = each %children) {
+ mv_tree($mailboxes, $mbx.$root, $mbx2.$root, %children);
+ }
+}
+
+# Syncronize mailbox list
+# XXX DELETE and RENAME not tested
+sub sync_tree($$%) {
+ my ($sth, $mbx, %children) = @_;
+ my %exists = map { $_ => exists_mbx($_,$mbx) } qw/local remote/;
+
+ my $rv = 0;
+ if ($exists{local} xor $exists{remote}) {
+ my ($exists,$missing) = $exists{local} ? ('local','remote') : ('remote','local');
+ my ($sth_by_mbx, $sth_by_uidvalidity) = @$sth{($missing.'_by_mbx', $exists.'_by_uidvalidity')};
+
+ # check if there is an entry matching $mbx for $missing in the database
+ $sth_by_mbx->execute($mbx);
+ my $row_by_mbx = $sth_by_mbx->fetch();
+ die if defined $sth_by_mbx->fetch(); # sanity check
+
+ if (defined $row_by_mbx) {
+ # $mbx was seen on $missing during the previous round: it
+ # has either been DELETEd or RENAMEd to another name on
+ # $missing.
+
+ my %uidvalidities = $IMAP->{$missing}->{client}->uidvalidity();
+ my ($idx,$uidvalidity) = @$row_by_mbx;
+ my @mbx2 = grep { $uidvalidities{$_} == $uidvalidity and !exists_mbx($exists,$_) }
+ keys %uidvalidities;
+
+ if ($#mbx2 > 0) {
+ # XXX this is allowed by RFC3501, but we can't guess...
+ msg($missing, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ",
+ join(',',@mbx2), "\n",
+ "Dunno which one $mbx should be renamed to.");
+ exit 1;
+ }
+ elsif (@mbx2) {
+ # $mbx's known (from the DB) UIDVALIDITY is that of
+ # $missing's $mbx2, which is not in the database and
+ # doesn't exist on $exists
+ msg($exists, "Rename mailbox $mbx to $mbx2[0]");
+ $sth->{rename}->execute($mbx2[0],$idx);
+ $IMAP->{$exists}->{client}->rename($mbx, $mbx2[0]);
+ $DBH->commit();
+ mv_tree($IMAP->{$exists}->{mailboxes}, $mbx, $mbx2[0], %children);
+ $mbx = $mbx2[0];
+ }
+ else {
+ # $mbx's known (from the DB) UIDVALIDITY on $missing
+ # was not found in any of $missing's mailboxes.
+ msg($exists, "Delete mailbox $mbx");
+ push @{$IMAP->{$exists}->{mailboxes}->{$mbx}}, '\NonExistent';
+ $IMAP->{$exists}->{client}->delete($mbx);
+ }
+ }
+ else {
+ # $mbx was never seen on $missing: it has either been
+ # CREATEd or RENAMEd from another name on $exists.
+
+ my ($idx,$mbx2);
+ if (defined (my $uidvalidity = $IMAP->{$exists}->{client}->uidvalidity($mbx))) {
+ $sth_by_uidvalidity->execute($uidvalidity);
+ my $by_uidvalidity = $sth_by_uidvalidity->fetchall_arrayref();
+ if (defined $by_uidvalidity and $#$by_uidvalidity > 0) {
+ # XXX this is allowed by RFC3501, but we can't guess...
+ my @mbx2 = map {$_->[1]} @$by_uidvalidity;
+ msg($exists, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ",
+ join(',',@mbx2), "\n",
+ "Dunno which one $mbx should be renamed to.");
+ exit 1;
+ }
+ ($idx,$mbx2) = @{$by_uidvalidity->[0]} if defined $by_uidvalidity and @$by_uidvalidity;
+ }
+
+ if (defined $mbx2) {
+ # $mbx's UIDVALIDITY on $exists can be found in the
+ # database as associated with $mbx2, which exists on
+ # $missing but not on $exists
+ msg($missing, "Rename mailbox $mbx2 to $mbx");
+ $sth->{rename}->execute($mbx,$idx);
+ $IMAP->{$missing}->{client}->rename($mbx2, $mbx);
+ $DBH->commit();
+ mv_tree($IMAP->{$missing}->{mailboxes}, $mbx2, $mbx, %children);
+ }
+ else {
+ # $mbx's UIDVALIDITY on $exists has never been found in
+ # the database.
+ msg($missing, "Create mailbox $mbx");
+ $IMAP->{$missing}->{mailboxes}->{$mbx} =
+ grep {lc $_ ne lc '\NonExistent'} @{$IMAP->{$missing}->{mailboxes}->{$mbx} // []};
+ $IMAP->{$missing}->{client}->create($mbx);
+ }
+ }
+ $rv = 1;
+ }
+
+ while (my ($root, $children) = each %children) {
+ my $r = sync_tree($sth, $mbx.$root, %$children);
+ $rv ||= $r;
+ }
+ return $rv;
+}
+
+{
+ my %delims;
+ foreach my $name (qw/local remote/) {
+ while (my ($mbx, $sep) = each %{$IMAP->{$name}->{delims}}) {
+ if (!exists $delims{$mbx}) {
+ $delims{$mbx} = $sep;
+ } else {
+ die "Hierarchy delimeters for mailbox $mbx don't match!\n"
+ unless (!defined $sep and !defined $delims{$mbx}) or
+ (defined $sep and defined $delims{$mbx} and $sep eq $delims{$mbx});
+ }
+ }
+ }
+
+ my $tree = make_tree(%delims);
+ my %sth;
+ $sth{$_.'_by_mbx'} = $DBH->prepare("SELECT idx,UIDVALIDITY FROM mailboxes NATURAL JOIN $_ WHERE mailbox = ?")
+ foreach qw/local remote/;
+ $sth{$_.'_by_uidvalidity'} = $DBH->prepare("SELECT idx,mailbox FROM mailboxes NATURAL JOIN $_ WHERE UIDVALIDITY = ?")
+ foreach qw/local remote/;
+ $sth{rename} = $DBH->prepare("UPDATE mailboxes SET mailbox = ? WHERE idx = ?");
+
+ my $updated = 0;
+ while (my ($mbx,$children) = each %$tree) {
+ #print $mbx, "\n";
+ #print_tree(0, %$children);
+ my $u = sync_tree(\%sth, $mbx, %$children);
+ $updated ||= $u;
+ }
+
+ if ($updated) {
+ # refresh the mailbox list
+ foreach my $name (qw/local remote/) {
+ @{$IMAP->{$name}}{qw/mailboxes delims/} = $IMAP->{$name}->{client}->list(q{"" "*"}, 'SUBSCRIBED');
+ }
+ my %mailboxes;
+ $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});
+ foreach my $mbx (keys %mailboxes) {
+ die "Could not sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx);
+ }
+ }
+}
+
+# Syncronize subscription list
+my @SUBSCRIPTIONS;
+{
+ my $sth_search = $DBH->prepare("SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?");
+ my $sth_subscribe = $DBH->prepare("UPDATE mailboxes SET subscribed = ? WHERE idx = ?");
+
+ my %mailboxes;
+ $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});
+
+ foreach my $mbx (keys %mailboxes) {
+ if (subscribed_mbx('local',$mbx) xor subscribed_mbx('remote',$mbx)) {
+ my ($subscribed,$unsubscribed) = subscribed_mbx('local',$mbx) ? ('local','remote') : ('remote','local');
+
+ $sth_search->execute($mbx);
+ my $row = $sth_search->fetch();
+ die if defined $sth_search->fetch(); # sanity check
+
+ if (defined $row) {
+ my ($idx,$status) = @$row;
+ if ($status) {
+ # $mbx was SUBSCRIBEd before, UNSUBSCRIBE it now
+ msg($subscribed, "Unsubscribe to mailbox $mbx");
+ $sth_subscribe->execute(0,$idx);
+ $IMAP->{$subscribed}->{client}->unsubscribe($mbx);
+ $DBH->commit();
+ $IMAP->{$subscribed}->{mailboxes}->{$mbx} =
+ grep {lc $_ ne lc '\Subscribed'} @{$IMAP->{$subscribed}->{mailboxes}->{$mbx} // []};
+ }
+ else {
+ # $mbx was UNSUBSCRIBEd before, SUBSCRIBE it now
+ msg($unsubscribed, "Subscribe to mailbox $mbx");
+ $sth_subscribe->execute(1,$idx);
+ $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
+ $DBH->commit();
+ $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= [];
+ push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed';
+ }
+ }
+ else {
+ # $mbx is unknown; assume the user wants to SUBSCRIBE
+ msg($unsubscribed, "Subscribe to mailbox $mbx");
+ $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
+ $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= [];
+ push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed';
+ }
+ }
+ push @SUBSCRIPTIONS, $mbx if subscribed_mbx('local', $mbx) and
+ subscribed_mbx('remote',$mbx);
+ }
+}
+
+# Clean database: remove mailboxes that no longer exist
+{
+ my $sth = $DBH->prepare("SELECT idx,mailbox,subscribed FROM mailboxes");
+ my $sth_delete_mailboxes = $DBH->prepare("DELETE FROM mailboxes WHERE idx = ?");
+ my $sth_delete_local = $DBH->prepare("DELETE FROM local WHERE idx = ?");
+ my $sth_delete_remote = $DBH->prepare("DELETE FROM remote WHERE idx = ?");
+ my $sth_delete_mapping = $DBH->prepare("DELETE FROM mapping WHERE idx = ?");
+
+ my @idx;
+ $sth->execute();
+ while (defined (my $row = $sth->fetch)) {
+ my ($idx,$mbx,$subscribed) = @$row;
+ if (!exists_mbx('local',$mbx) and !exists_mbx('remote',$mbx)) {
+ $_->execute($idx) foreach ($sth_delete_mapping,$sth_delete_local,$sth_delete_remote);
+ $sth_delete_mailboxes->execute($idx) if
+ !exists $IMAP->{local}->{mailboxes}->{$mbx} and
+ !exists $IMAP->{remote}->{mailboxes}->{$mbx};
+ $DBH->commit();
+ }
+ }
+}
+
+
+
+#############################################################################
+# Synchronize messages
+# Consider only the mailboxes in @ARGV, if the list is non-empty.
+
+my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
+undef $IMAP;
+
+
+# Get all cached states from the database.
+my $STH_GET_CACHE = $DBH->prepare(q{
+ SELECT mailbox,
+ l.UIDVALIDITY as lUIDVALIDITY, l.UIDNEXT as lUIDNEXT, l.HIGHESTMODSEQ as lHIGHESTMODSEQ,
+ r.UIDVALIDITY as rUIDVALIDITY, r.UIDNEXT as rUIDNEXT, r.HIGHESTMODSEQ as rHIGHESTMODSEQ
+ FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
+});
+
+# Get the index associated with a mailbox.
+my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx FROM mailboxes WHERE mailbox = ?});
+
+# Find local/remote UID from the map.
+my $STH_GET_LOCAL_UID = $DBH->prepare("SELECT lUID FROM mapping WHERE idx = ? and rUID = ?");
+my $STH_GET_REMOTE_UID = $DBH->prepare("SELECT rUID FROM mapping WHERE idx = ? and lUID = ?");
+
+# Delete a (idx,lUID,rUID) association.
+# /!\ Don't commit before the messages have actually been EXPUNGEd on
+# both sides!
+my $STH_DELETE_MAPPING = $DBH->prepare("DELETE FROM mapping WHERE idx = ? and lUID = ?");
+
+# Update the HIGHESTMODSEQ.
+my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?});
+my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?});
+
+# Update the HIGHESTMODSEQ and UIDNEXT.
+my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
+my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
+
+# Add a new mailbox.
+my $STH_NEWMAILBOX = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
+my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
+my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
+
+# Insert a (idx,lUID,rUID) association.
+my $STH_INSERT_MAPPING = $DBH->prepare("INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)");
+
+
+# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
+$STH_GET_CACHE->execute();
+while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
+ $lIMAP->set_cache($row->{mailbox},
+ UIDVALIDITY => $row->{lUIDVALIDITY},
+ UIDNEXT => $row->{lUIDNEXT},
+ HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ}
+ );
+ $rIMAP->set_cache($row->{mailbox},
+ UIDVALIDITY => $row->{rUIDVALIDITY},
+ UIDNEXT => $row->{rUIDNEXT},
+ HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
+ );
+}
+
+
+# Sync known messages. Since pull_updates is the last method call on
+# $lIMAP and $rIMAP, it is safe to call get_cache on either object after
+# this function, in order to update the HIGHESTMODSEQ.
+# Return true if an update was detected, and false otherwise
+sub sync_known_messages($) {
+ my $idx = shift;
+ my $update = 0;
+
+ # loop since processing might produce VANISHED or unsollicited FETCH responses
+ while (1) {
+ my ($lVanished, $lModified) = $lIMAP->pull_updates();
+ my ($rVanished, $rModified) = $rIMAP->pull_updates();
+
+ # repeat until we have nothing pending
+ return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished;
+ $update = 1;
+
+ # process VANISHED messages
+ # /!\ this might modify the VANISHED or MODIFIED cache!
+ if (@$lVanished or @$rVanished) {
+ my %lVanished = map {$_ => 1} @$lVanished;
+ my %rVanished = map {$_ => 1} @$rVanished;
+
+ # For each vanished UID, get the corresponding one on the
+ # other side (from the DB); consider it as to be removed if
+ # it hasn't been removed already.
+
+ my (@lToRemove, @rToRemove);
+ foreach my $lUID (@$lVanished) {
+ $STH_GET_REMOTE_UID->execute($idx, $lUID);
+ my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
+ die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $rUID) {
+ warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+ }
+ elsif (!exists $rVanished{$rUID}) {
+ push @rToRemove, $rUID;
+ }
+ }
+ foreach my $rUID (@$rVanished) {
+ $STH_GET_LOCAL_UID->execute($idx, $rUID);
+ my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
+ die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $lUID) {
+ warn "WARNING: Couldn't find a matching lUID for (idx,rUID) = ($idx,$rUID)\n";
+ }
+ elsif (!exists $lVanished{$lUID}) {
+ push @lToRemove, $lUID;
+ }
+ }
+
+ $lIMAP->remove(@lToRemove) if @lToRemove;
+ $rIMAP->remove(@rToRemove) if @rToRemove;
+
+ # remove existing mappings
+ foreach my $lUID (@$lVanished, @lToRemove) {
+ my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
+ die if $r > 1; # sanity check
+ warn "WARNING: Couldn't delete (idx,lUID) pair ($idx,$lUID)\n" if $r == 0;
+ }
+ }
+
+ # process FLAG updates
+ # /!\ this might modify the VANISHED or MODIFIED cache!
+ if (%$lModified or %$rModified) {
+ my (%lToUpdate, %rToUpdate);
+
+ # Take flags updates on both sides, and get the
+ # corresponding UIDs on the other side (from the DB).
+ # If it wasn't modified there, make it such; if it was
+ # modified with the same flags list, ignore that message;
+ # otherwise there is a conflict, and take the union.
+ #
+ # Group by flags in order to limit the number of round
+ # trips.
+
+ while (my ($lUID,$lFlags) = each %$lModified) {
+ $STH_GET_REMOTE_UID->execute($idx, $lUID);
+ my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
+ die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $rUID) {
+ warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+ }
+ elsif (defined (my $rFlags = $rModified->{$rUID})) {
+ unless ($lFlags eq $rFlags) {
+ my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags));
+ my $flags = join ' ', sort(keys %flags);
+ warn "WARNING: Conflicting FLAG update for lUID $lUID ($lFlags) and".
+ "rUID $rUID ($rFlags). Setting both to the union ($flags).\n";
+ $lToUpdate{$flags} //= [];
+ push @{$lToUpdate{$flags}}, $lUID;
+ $rToUpdate{$flags} //= [];
+ push @{$rToUpdate{$flags}}, $rUID;
+ }
+ }
+ else {
+ $rToUpdate{$lFlags} //= [];
+ push @{$rToUpdate{$lFlags}}, $rUID;
+ }
+ }
+ while (my ($rUID,$rFlags) = each %$rModified) {
+ $STH_GET_LOCAL_UID->execute($idx, $rUID);
+ my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
+ die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $lUID) {
+ warn "WARNING: Couldn't find a matching rUID for (idx,rUID) = ($idx,$rUID)\n";
+ }
+ elsif (!exists $lModified->{$lUID}) {
+ # conflicts are taken care of above
+ $lToUpdate{$rFlags} //= [];
+ push @{$lToUpdate{$rFlags}}, $lUID;
+ }
+ }
+
+ while (my ($lFlags,$lUIDs) = each %lToUpdate) {
+ $lIMAP->push_flag_updates($lFlags, @$lUIDs);
+ }
+ while (my ($rFlags,$rUIDs) = each %rToUpdate) {
+ $rIMAP->push_flag_updates($rFlags, @$rUIDs);
+ }
+ }
+ }
+}
+
+
+# Sync known and new messages
+sub sync_messages($$) {
+ my ($idx, $mailbox) = @_;
+
+ my %mapping;
+ foreach my $source (qw/remote local/) {
+ my $target = $source eq 'local' ? $rIMAP : $lIMAP;
+ my $multiappend;
+
+ my @newmails;
+ my $buffer = 0; # sum of the RFC822 sizes in @newmails
+
+ my (@sUID, @tUID);
+
+ # don't fetch again the messages we've just added
+ my @ignore = $source eq 'local' ? keys %mapping : values %mapping;
+
+ ($source eq 'local' ? $lIMAP : $rIMAP)->pull_new_messages(sub(%) {
+ my %mail = @_;
+ return unless exists $mail{RFC822}; # not for us
+
+ my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE});
+ push @sUID, $mail{UID};
+
+ # use MULTIAPPEND if possible (RFC 3502) to save round-trips
+ $multiappend //= !$target->incapable('MULTIAPPEND');
+
+ if (!$multiappend) {
+ my ($uid) = $target->append($mailbox, @mail);
+ push @tUID, $uid;
+ }
+ else {
+ # proceed by batch of 1MB to save roundtrips without blowing up the memory
+ if (@newmails and $buffer + length($mail{RFC822}) > 1048576) {
+ push @tUID, $target->append($mailbox, @newmails);
+ @newmails = ();
+ $buffer = 0;
+ }
+ push @newmails, @mail;
+ $buffer += length $mail{RFC822};
+ }
+ }, @ignore);
+ push @tUID, $target->append($mailbox, @newmails) if @newmails;
+
+ die unless $#sUID == $#tUID; # sanity check
+ foreach my $k (0 .. $#sUID) {
+ my ($lUID,$rUID) = $source eq 'local' ? ($sUID[$k],$tUID[$k]) : ($tUID[$k],$sUID[$k]);
+ die if exists $mapping{$lUID}; # sanity check
+ $mapping{$lUID} = $rUID;
+ }
+ }
+
+ # new mailbox
+ if (!defined $$idx) {
+ my $subscribed = grep { $_ eq $mailbox} @SUBSCRIPTIONS ? 1 : 0;
+ $STH_NEWMAILBOX->execute($mailbox, $subscribed);
+ $STH_GET_INDEX->execute($mailbox);
+ ($$idx) = $STH_GET_INDEX->fetchrow_array();
+ die if !defined $$idx or defined $STH_GET_INDEX->fetchrow_arrayref(); # sanity check
+
+ # there might be flag updates pending
+ sync_known_messages($$idx);
+ $STH_INSERT_LOCAL->execute($$idx, $lIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
+ $STH_INSERT_REMOTE->execute($$idx, $rIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
+ }
+ else {
+ # update known mailbox
+ sync_known_messages($$idx);
+ $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
+ $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
+ }
+
+ while (my ($lUID,$rUID) = each %mapping) {
+ $STH_INSERT_MAPPING->execute($$idx, $lUID, $rUID);
+ }
+ $DBH->commit();
+}
+
+
+
+# Wait for notifications on either IMAP server, up to $timout. Then
+# issue a NOOP so the connection doesn't terminate for inactivity.
+sub wait_notifications(;$) {
+ my $timeout = shift // 300;
+
+ while ($timeout > 0) {
+ my $r1 = $lIMAP->slurp();
+ my $r2 = $rIMAP->slurp();
+ last if $r1 or $r2; # got update!
+
+ sleep 1;
+ if (--$timeout == 0) {
+ $lIMAP->noop();
+ $rIMAP->noop();
+ }
+ }
+}
+
+
+my ($mailbox, $idx);
+while(1) {
+ while(1) {
+ my $cache;
+ my $update = 0;
+ if (defined $mailbox and ($lIMAP->is_dirty($mailbox) or $rIMAP->is_dirty($mailbox))) {
+ # $mailbox is dirty on either the local or remote mailbox
+ sync_messages(\$idx, $mailbox);
+ }
+ else {
+ $mailbox = $lIMAP->next_dirty_mailbox(@ARGV) // $rIMAP->next_dirty_mailbox(@ARGV) // last;
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case insensitive
+
+ $STH_GET_INDEX->execute($mailbox);
+ ($idx) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+
+ $lIMAP->select($mailbox);
+ $rIMAP->select($mailbox);
+
+ # sync updates to known messages before fetching new messages
+ if (defined $idx and sync_known_messages($idx)) {
+ # get_cache is safe after pull_update
+ $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $idx);
+ $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $idx);
+ $DBH->commit();
+ }
+ sync_messages(\$idx, $mailbox);
+ }
+ }
+ # clean state!
+ exit 0 if $CONFIG{oneshot};
+ wait_notifications(900);
+}
+
+END { clean (); }
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 18:25:17 +0000