From e3198504c14ed04edc4f3c317e880602a35385a1 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 23 Jul 2015 04:18:47 +0200 Subject: First attempt. --- imapsync | 796 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 796 insertions(+) create mode 100755 imapsync (limited to 'imapsync') 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 +# +# 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 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 (); } -- cgit v1.2.3