aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-ximapsync590
-rw-r--r--imapsync.1124
-rw-r--r--imapsync.sample19
-rw-r--r--imapsync.service5
-rw-r--r--lib/Net/IMAP/Sync.pm176
5 files changed, 493 insertions, 421 deletions
diff --git a/imapsync b/imapsync
index 339979c..b0226c3 100755
--- a/imapsync
+++ b/imapsync
@@ -39,29 +39,38 @@ delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
my %CONFIG;
sub usage(;$) {
my $rv = shift // 0;
- print STDERR "$NAME [OPTIONS] [--] [MAILBOX [..]]\n";
if ($rv) {
- print STDERR "Try '$NAME --help' or consult the manpage for more information.\n";
+ print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n"
+ ."Try '$NAME --help' or consult the manpage for more information.\n";
}
else {
- print STDERR "Synchronize the given MAILBOXes between two QRESYNC-capable IMAP4rev1 servers.\n"
- ."Options:\n"
- ." --config=FILE Specify an alternate configuration file\n"
- ." --repair List the database anomalies and try to repair them\n"
- ." -q, --quiet Try to be quiet\n"
- ." --debug Turn on debug mode\n"
- ."Consult the manpage for more information.\n";
+ 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 repair debug help|h/);
+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/ );
+ , 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);
{
@@ -207,7 +216,7 @@ logger(undef, ">>> $NAME $VERSION");
my $IMAP;
foreach my $name (qw/local remote/) {
my %config = %{$CONF->{$name}};
- $config{$_} = $CONFIG{$_} foreach keys %CONFIG;
+ $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/;
$config{enable} = 'QRESYNC';
$config{name} = $name;
$config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
@@ -229,331 +238,279 @@ foreach my $name (qw/local remote/) {
# 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)' );
+
+ 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);
}
-#############################################################################
-# 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);
+# 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 \%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;
+ return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef;
}
-# 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;
+
+# 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;
}
-# 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);
- }
+# 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;
}
-# 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) or
- msg('database', "WARNING: Can't rename $mbx to $mbx2[0]");
- $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) or
- msg('database', "WARNING: Can't rename $mbx2 to $mbx2");
- $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);
- }
+##############################################################################
+# 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);
}
- $rv = 1;
- }
- while (my ($root, $children) = each %children) {
- my $r = sync_tree($sth, $mbx.$root, %$children);
- $rv ||= $r;
+ 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;
+ }
}
- return $rv;
+ exit 0;
}
-{
- my %delims;
+
+##############################################################################
+# 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/) {
- 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});
- }
+ 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;
}
}
- 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(q{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;
+ # 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;
}
- 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 "Couldn't sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx);
+
+ # 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 subscription list
-my @SUBSCRIPTIONS;
+
+##############################################################################
+# Synchronize mailbox and subscription lists
+
+my @MAILBOXES;
{
- my $sth_search = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?});
+ 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 = ?});
- my %mailboxes;
- $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});
-
- foreach my $mbx (keys %mailboxes) {
- $sth_search->execute($mbx);
- my $row = $sth_search->fetch();
- die if defined $sth_search->fetch(); # sanity check
-
- my ($lSubscribed,$rSubscribed) = map {subscribed_mbx($_,$mbx)} qw/local remote/;
- if ($lSubscribed == $rSubscribed) {
- if (defined $row) {
- my ($idx,$status) = @$row;
- if (defined $status and $status != $lSubscribed) {
- $sth_subscribe->execute($lSubscribed, $idx) or
- msg('database', "WARNING: Can't (un)subscribe $mbx");
- $DBH->commit();
- }
- }
- }
- else {
- my ($subscribed,$unsubscribed) = $lSubscribed ? qw/local remote/ : qw/remote local/;
- 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) or
- msg('database', "WARNING: Can't unsubscribe $mbx");
- $IMAP->{$subscribed}->{client}->unsubscribe($mbx);
+ 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();
- $lSubscribed = $rSubscribed = 0;
}
- else {
- # $mbx was UNSUBSCRIBEd before, SUBSCRIBE it now
- msg($unsubscribed, "Subscribe to mailbox $mbx");
- $sth_subscribe->execute(1,$idx) or
- msg('database', "WARNING: Can't subscribe $mbx");
- $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
+ # $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();
- $lSubscribed = $rSubscribed = 1;
}
}
else {
- # $mbx is unknown; assume the user wants to SUBSCRIBE
- msg($unsubscribed, "Subscribe to mailbox $mbx");
- $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
- $lSubscribed = $rSubscribed = 1;
+ # 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();
}
}
- push @SUBSCRIPTIONS, $mbx if $lSubscribed;
- }
-}
-
-# Clean database: remove mailboxes that no longer exist
-{
- my $sth = $DBH->prepare(q{SELECT idx,mailbox,subscribed FROM mailboxes});
- 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 = ?});
-
- 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};
+ 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
-# 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
+ 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
+ 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 = ?
});
-# 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(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 = ?});
@@ -571,7 +528,6 @@ my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMO
my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
# Add a new mailbox.
-my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
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)});
@@ -650,9 +606,20 @@ sub delete_mapping($$) {
# Check and repair synchronization of a mailbox between the two servers
# (in a very crude way, by downloading all existing UID with their flags)
-my @REPAIR;
-sub repair($$) {
- my ($idx, $mailbox) = @_;
+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
+ $lIMAP->select($mailbox);
+ $rIMAP->select($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);
@@ -665,10 +632,6 @@ sub repair($$) {
my (@rToRemove, %rToUpdate, @rMissing);
my @delete_mapping;
- $STH_GET_CACHE_BY_IDX->execute($idx);
- my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // die "Missing cache for index $idx";
- die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check
-
# process each pair ($lUID,$rUID) found in the mapping table, and
# compare with the result from the IMAP servers to detect anomalies
@@ -1024,10 +987,13 @@ sub wait_notifications(;$) {
}
+#############################################################################
# Resume interrupted mailbox syncs.
+#
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");
@@ -1075,10 +1041,13 @@ while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) {
}
-
+#############################################################################
# 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},
@@ -1089,26 +1058,17 @@ while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
UIDNEXT => $row->{rUIDNEXT},
HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
);
- push @REPAIR, $row->{mailbox} if $CONFIG{repair} and
- (!@ARGV or grep { $_ eq $row->{mailbox} } @ARGV);
+ $KNOWN_INDEXES{$row->{idx}} = 1;
}
-while (@REPAIR) {
- $MAILBOX = shift @REPAIR;
-
- $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);
- repair($IDX, $MAILBOX);
+if (defined $COMMAND and $COMMAND eq 'repair') {
+ repair($_) foreach @MAILBOXES;
+ exit 0;
}
-exit 0 if $CONFIG{repair};
while(1) {
- while(1) {
+ while(@MAILBOXES) {
my $cache;
my $update = 0;
if (defined $MAILBOX and ($lIMAP->is_dirty($MAILBOX) or $rIMAP->is_dirty($MAILBOX))) {
@@ -1116,28 +1076,23 @@ while(1) {
sync_messages($IDX, $MAILBOX);
}
else {
- $MAILBOX = $lIMAP->next_dirty_mailbox(@ARGV) // $rIMAP->next_dirty_mailbox(@ARGV) // last;
+ $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;
$lIMAP->select($MAILBOX);
$rIMAP->select($MAILBOX);
- # new mailbox
- if (!defined $IDX) {
- my $subscribed = (grep { $_ eq $MAILBOX} @SUBSCRIPTIONS) ? 1 : 0;
- $STH_INSERT_MAILBOX->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
-
+ if (!$KNOWN_INDEXES{$IDX}) {
$STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX));
$STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX));
- # don't commit before the first mapping (lUID,rUID)
+ # 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
@@ -1152,8 +1107,11 @@ while(1) {
}
}
# clean state!
- exit 0 unless $CONFIG{watch};
+ exit 0 unless defined $COMMAND and $COMMAND eq 'watch';
wait_notifications(900);
}
-END { cleanup(); }
+END {
+ $_->logout() foreach grep defined, ($lIMAP, $rIMAP);
+ cleanup();
+}
diff --git a/imapsync.1 b/imapsync.1
index 8c22222..d794d1a 100644
--- a/imapsync.1
+++ b/imapsync.1
@@ -4,7 +4,7 @@
imapsync \- IMAP-to-IMAP synchronization program for QRESYNC-capable servers
.SH SYNOPSIS
-.B imapsync\fR [\fIOPTION\fR ...] [\fIMAILBOX\fR ...]
+.B imapsync\fR [\fIOPTION\fR ...] [\fICOMMAND\fR] [\fIMAILBOX\fR ...]
.SH DESCRIPTION
@@ -12,12 +12,12 @@ imapsync \- IMAP-to-IMAP synchronization program for QRESYNC-capable servers
.B imapsync\fR performs stateful synchronization between two IMAP4rev1
servers.
Such synchronization is made possible by the QRESYNC extension from
-[RFC7162]; for convenience reasons support for LIST\-EXTENDED [RFC5258],
-LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315] is also required.
-Furthermore, support for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502]
-is recommended: while they are not needed for \fBimapsync\fR to work,
-these extensions greatly improve performance by reducing the number of
-required round trips.
+[RFC7162]; for convenience reasons servers must also support
+LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315].
+Furthermore, while \fBimapsync\fR can work with servers lacking support
+for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions
+greatly improve performance by reducing the number of required round
+trips hence are recommended.
.PP
Stateful synchronization is only possible for mailboxes supporting
@@ -69,11 +69,18 @@ Go back to step 2 if the server sent some updates in the meantime.
.IP \n+[step].
Go back to step 1 to proceed with the next unsynchronized mailbox.
+.SH COMMANDS
.PP
By default \fBimapsync\fR synchronizes each mailbox listed by the
\(lqLIST "" "*"\(rq IMAP command;
-providing extra arguments limits the synchronization to the given
-\fIMAILBOX\fRes only.
+the \fIlist-mailbox\fR, \fIlist-select-opts\fR and \fIignore-mailbox\fR
+options from the configuration file can be used to shrink that list and
+save bandwidth.
+However if some extra argument are provided on the command line,
+\fBimapsync\fR ignores said options and synchronizes the given
+\fIMAILBOX\fRes instead. Note that each \fIMAILBOX\fR is taken \(lqas
+is\(rq; in particular, it must be UTF-7 encoded, unquoted, and the list
+wildcards \(oq*\(cq and \(oq%\(cq are not interpolated.
.PP
If the synchronization was interrupted during a previous run while some
@@ -86,16 +93,15 @@ their flags have changed in the meantime.
Finally, after propagating the offline changes for these messages,
\fBimapsync\fR resumes the synchronization for the rest of the mailbox.
-.SH OPTIONS
-.TP
-.B \-\-config=\fR\fIFILE\fR
-Specify an alternate configuration file. Relative paths start from
-\fI$XDG_CONFIG_HOME\fR, or \fI~/.config\fR if the XDG_CONFIG_HOME
-environment variable is unset.
+.PP
+Specifying one of the commands below makes \fBimapsync\fR perform an
+action other than the default QRESYNC-based synchronization.
.TP
-.B \-\-repair
+.B \-\-repair \fR[\fIMAILBOX\fR ...]
List the database anomalies and try to repair them.
+(Consider only the given \fIMAILBOX\fRes if non-optional arguments are
+provided.)
This is done by performing a so\-called \(lqfull synchronization\(rq,
namely 1/ download all UIDs along with their flags from both the local
and remote servers, 2/ ensure that each entry in the database corresponds
@@ -107,6 +113,37 @@ Flag conflicts are solved by updating each message to the union of both
lists.
.TP
+.B \-\-delete \fIMAILBOX\fR [...]
+Delete the given \fIMAILBOX\fRes on each target (by default each server
+plus the database, unless \fB\-\-target\fR specifies otherwise) where
+it exists.
+Note that per [RFC3501] deletion is not recursive: \fIMAILBOX\fR's
+children are not deleted.
+
+.TP
+.B \-\-rename \fISOURCE\fR \fIDEST\fR
+Rename the mailbox \fISOURCE\fR to \fIDEST\fR on each target (by default
+each server plus the database, unless \fB\-\-target\fR specifies
+otherwise) where it exists.
+\fBimapsync\fR aborts if \fIDEST\fR already exists on either target.
+Note that per [RFC3501] the renaming is recursive: \fISOURCE\fR's
+children are moved to become \fIDEST\fR's children instead.
+
+
+.SH OPTIONS
+.TP
+.B \-\-config=\fR\fIFILE\fR
+Specify an alternate configuration file. Relative paths start from
+\fI$XDG_CONFIG_HOME\fR, or \fI~/.config\fR if the XDG_CONFIG_HOME
+environment variable is unset.
+
+.TP
+.B \fB\-\-target=\fR{local,remote,database}
+Limit the scope of a \fB\-\-delete\fR or \fB\-\-rename\fR command
+to the given target. Can be repeated to act on multiple targets. By
+default all three targets are considered.
+
+.TP
.B \-q\fR, \fB\-\-quiet\fR
Try to be quiet.
@@ -151,6 +188,42 @@ This option is only available in the default section.
\(lq[remote]\(rq or \(lq[local]\(rq sections, in that order.
.TP
+.I list-mailbox
+A space separated list of mailbox patterns to use when issuing the
+initial LIST command (overridden by the \fIMAILBOX\fRes given as
+command-line arguments).
+Note that each pattern containing special characters such as spaces or
+brackets (see [RFC3501] for the exact syntax) must be quoted.
+Furthermore, non-ASCII names must be UTF\-7 encoded.
+Two wildcards are available: a \(oq*\(cq character matches zero or more
+characters, while a \(oq%\(cq character matches zero or more characters
+up to the mailbox's hierarchy delimiter.
+This option is only available in the default section.
+(The default pattern, \(lq*\(rq, matches all visible mailboxes on the
+server.)
+
+.TP
+.I list-select-opts
+An optional space separated list of selectors for the initial LIST
+command. (Requires a server supporting the LIST-EXTENDED [RFC5258]
+extension.) Useful values are
+\(lqSUBSCRIBED\(rq (to list only subscribed mailboxes),
+\(lqREMOTE\(rq (to also list remote mailboxes on a server supporting
+mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes
+with children matching one of the \fIlist-mailbox\fR patterns above).
+This option is only available in the default section.
+
+.TP
+.I ignore-mailbox
+An optional Perl Compatible Regular Expressions (PCRE) covering
+mailboxes to exclude:
+any (UTF-7 encoded, unquoted) mailbox listed in the initial LIST
+responses is ignored if it matches the given expression.
+Note that the \fIMAILBOX\fRes given as command-line arguments bypass the
+check and are always considered for synchronization.
+This option is only available in the default section.
+
+.TP
.I logfile
A file name to use to log debug and informational messages. This option is
only available in the default section.
@@ -231,25 +304,16 @@ Authorities, used for server certificate verification.
.SH KNOWN BUGS AND LIMITATIONS
-.IP \[bu] 2
-Mailbox deletion and renaming are not very well tested yet.
.IP \[bu]
Using \fBimapsync\fR on two identical servers with a non-existent or
-empty database will duplicate each message due to absence of
+empty database will duplicate each message due to the absence of
local/remote UID association.
.IP \[bu]
-Detecting whether a mailbox has been renamed or deleted while
-\fBimapsync\fR wasn't running is done by looking for a mailbox with same
-UIDVALIDITY. [RFC3501] describes the purpose of UIDVALIDITY as to let
-clients know when to invalidate their UID cache. In particular, there
-is no requirement that two mailboxes can't share same UIDVALIDITY.
-However such a possibility would defeat \fBimapsync\fR's heuristic to
-detect whether a mailbox has been renamed or deleted offline.
-.IP \[bu]
\fBimapsync\fR is single threaded and doesn't use IMAP command
-pipelining. Performance improvement could be achieved by sending
-independent commands to each server in parallel, and for a given server,
-by sending independent commands (such as flag updates) in a pipeline.
+pipelining. Synchronization could be boosted by sending independent
+commands (such as the initial LIST/STATUS command) to each server in
+parallel, and for a given server, by sending independent commands (such
+as flag updates) in a pipeline.
.IP \[bu]
Because the IMAP protocol doesn't have a specific response code for when
a message is moved to another mailbox (using the MOVE command from
diff --git a/imapsync.sample b/imapsync.sample
index e563e94..296f766 100644
--- a/imapsync.sample
+++ b/imapsync.sample
@@ -1,20 +1,23 @@
-; database = imap.guilhem.org.db
+# database = imap.guilhem.org.db
+#list-mailbox = "*"
+list-select-opts = SUBSCRIBED
+ignore-mailbox = ^virtual/
[local]
type = tunnel
command = /usr/lib/dovecot/imap
[remote]
-; type = imaps
+# type = imaps
host = imap.guilhem.org
-; port = 993
+# port = 993
username = guilhem
password = xxxxxxxxxxxxxxxx
-; SSL options
-;SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
-;SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605
-;SSL_verify_trusted_peer = YES
+# SSL options
+#SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
+#SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605
+#SSL_verify_trusted_peer = YES
SSL_ca_path = /etc/ssl/certs
-; vim:ft=dosini
+# vim:ft=dosini
diff --git a/imapsync.service b/imapsync.service
index af63425..725f23b 100644
--- a/imapsync.service
+++ b/imapsync.service
@@ -1,9 +1,12 @@
[Unit]
Description=IMAP-to-IMAP Syncronization service
-After=network.target
+Wants=network-online.target
+After=network-online.target
[Service]
ExecStart=/usr/bin/imapsync
+RestartSec=60s
+Restart=on-success
[Install]
WantedBy=default.target
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
index 3216483..47c6258 100644
--- a/lib/Net/IMAP/Sync.pm
+++ b/lib/Net/IMAP/Sync.pm
@@ -47,7 +47,6 @@ my %OPTIONS = (
password => qr/\A([\x01-\x7F]+)\z/,
auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
command => qr/\A(\/\P{Control}+)\z/,
- 'read-only' => qr/\A(YES|NO)\z/i,
SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
SSL_cipher_list => qr/\A(\P{Control}+)\z/,
SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
@@ -79,10 +78,11 @@ sub read_config($$%) {
foreach my $section (@$sections) {
my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section
$configs{$section} = $conf;
- next unless defined $section and $section ne '_';
- die "No such section $section\n" unless defined $h->{$section};
- $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
+ if ($section ne '_') {
+ die "No such section $section\n" unless defined $h->{$section};
+ $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
+ }
# default values
$conf->{type} //= 'imaps';
@@ -210,10 +210,6 @@ our $IMAP_text;
#
# - 'name': An optional instance name to include in log messages.
#
-# - 'read-only': Use only commands that don't modify the server state.
-# In particular, use EXAMINE in place of SELECT for mailbox
-# selection.
-#
# - 'extra-attrs': An attribute or list of extra attributes to FETCH
# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
# BODY.PEEK[]).
@@ -225,9 +221,6 @@ sub new($%) {
my $self = { @_ };
bless $self, $class;
- # whether we're allowed to to use read-write command
- $self->{'read-only'} = uc ($self->{'read-only'} // 'NO') ne 'YES' ? 0 : 1;
-
# the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
# (cf RFC 3501 section 3)
$self->{_STATE} = '';
@@ -386,9 +379,8 @@ sub new($%) {
# Log out when the Net::IMAP::Sync object is destroyed.
sub DESTROY($) {
my $self = shift;
- if (defined $self->{STDIN} and $self->{STDIN}->opened() and
- defined $self->{STDOUT} and $self->{STDOUT}->opened()) {
- $self->logout();
+ foreach (qw/STDIN STDOUT/) {
+ $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
}
}
@@ -480,14 +472,12 @@ sub search($$) {
# $self->select($mailbox)
# $self->examine($mailbox)
-# Issue a SELECT or EXAMINE command for the $mailbox. (Always use
-# EXAMINE if the 'read-only' flag is set.) Upon success, change the
-# state to SELECTED, otherwise go back to AUTH.
+# Issue a SELECT or EXAMINE command for the $mailbox. Upon success,
+# change the state to SELECTED, otherwise go back to AUTH.
sub select($$) {
my $self = shift;
my $mailbox = shift;
- my $cmd = $self->{'read-only'} ? 'EXAMINE' : 'SELECT';
- $self->_select_or_examine($cmd, $mailbox);
+ $self->_select_or_examine('SELECT', $mailbox);
}
sub examine($$) {
my $self = shift;
@@ -500,7 +490,8 @@ sub examine($$) {
# Issue a LOGOUT command. Change the state to LOGOUT.
sub logout($) {
my $self = shift;
- $self->_send('LOGOUT');
+ # don't bother if the connection is already closed
+ $self->_send('LOGOUT') if $self->{STDIN}->opened();
$self->{_STATE} = 'LOGOUT';
undef $self;
}
@@ -513,48 +504,99 @@ sub noop($) {
}
-# $self->create($mailbox)
-# $self->delete($mailbox)
-# CREATE or DELETE $mailbox. Requires the 'read-only' flag to be unset.
-sub create($$) {
- my ($self, $mailbox) = @_;
- $self->fail("Server is read-only.") if $self->{'read-only'};
- $self->_send("CREATE ".quote($mailbox));
+# $self->create($mailbox, [$try])
+# $self->delete($mailbox, [$try])
+# CREATE or DELETE $mailbox.
+# If try is set, print a warning but don't crash if the command fails.
+sub create($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("CREATE ".quote($mailbox));
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Created mailbox ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
}
-sub delete($$) {
- my ($self, $mailbox) = @_;
- $self->fail("Server is read-only.") if $self->{'read-only'};
- #$self->_send("DELETE ".quote($mailbox));
+sub delete($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("DELETE ".quote($mailbox));
delete $self->{_CACHE}->{$mailbox};
delete $self->{_PCACHE}->{$mailbox};
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
}
-# $self->rename($oldname, $newname)
-# RENAME the mailbox $oldname to $newname. Requires the 'read-only'
-# flag to be unset.
-sub rename($$$) {
- my ($self, $from, $to) = @_;
- $self->fail("Server is read-only.") if $self->{'read-only'};
- $self->_send("RENAME ".quote($from).' '.quote($to));
+# $self->rename($oldname, $newname, [$try])
+# RENAME the mailbox $oldname to $newname.
+# If $try is set, print a warning but don't crash if the command fails.
+# /!\ Requires a LIST command to be issued to determine the hierarchy
+# delimiter and the mailbox attributes for the original name.
+sub rename($$$;$) {
+ my ($self, $from, $to, $try) = @_;
+ my ($delim, @attrs);
+ if ($self->{_CACHE}->{$from}) {
+ $delim = $self->{_CACHE}->{$from}->{DELIMITER};
+ @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []};
+ }
+ my $r = $self->_send("RENAME ".quote($from).' '.quote($to));
$self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from};
$self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from};
+ if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) {
+ # on non-flat mailboxes, move children as well (cf 3501)
+ foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) {
+ my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r;
+ $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1};
+ $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1};
+ }
+ }
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
}
-# $self->subscribe($mailbox)
-# $self->unsubscribe($mailbox)
-# SUBSCRIBE or UNSUBSCRIBE $mailbox. Requires the 'read-only' flag to
-# be unset.
-sub subscribe($$) {
- my ($self, $mailbox) = @_;
- $self->fail("Server is read-only.") if $self->{'read-only'};
- $self->_send("SUBSCRIBE ".quote($mailbox));
+# $self->subscribe($mailbox, [$try])
+# $self->unsubscribe($mailbox, [$try])
+# SUBSCRIBE or UNSUBSCRIBE $mailbox.
+# If $try is set, print a warning but don't crash if the command fails.
+sub subscribe($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("SUBSCRIBE ".quote($mailbox));
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Subscribe to ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
}
-sub unsubscribe($$) {
- my ($self, $mailbox) = @_;
- $self->fail("Server is read-only.") if $self->{'read-only'};
- $self->_send("UNSUBSCRIBE ".quote($mailbox));
+sub unsubscribe($$;$) {
+ my ($self, $mailbox, $try) = @_;
+ my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox));
+ if ($IMAP_cond eq 'OK') {
+ $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet};
+ }
+ else {
+ my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text;
+ $try ? $self->warn($msg) : $self->fail($msg);
+ }
+ return $r;
}
@@ -624,7 +666,6 @@ sub append($$@) {
my $self = shift;
my $mailbox = shift;
return unless @_;
- $self->fail("Server is read-only.") if $self->{'read-only'};
$self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
if $self->incapable('UIDPLUS');
@@ -1060,10 +1101,15 @@ sub _getline($;$) {
my $self = shift;
my $msg = shift // '';
- my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
- $x =~ s/\r\n\z// or $self->panic($x);
- $self->logger("S: $msg", $x) if $self->{debug};
- return $x;
+ if ($self->{STDOUT}->opened()) {
+ my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
+ $x =~ s/\r\n\z// or $self->panic($x);
+ $self->logger("S: $msg", $x) if $self->{debug};
+ return $x;
+ }
+ else {
+ undef $self;
+ }
}
@@ -1151,7 +1197,7 @@ sub _send($$;&) {
$IMAP_cond = $1;
$IMAP_text = $1.' '.$x;
$self->_resp_text($x);
- $self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK';
+ $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK';
$r = $1;
last;
}
@@ -1219,9 +1265,8 @@ sub _open_mailbox($$) {
# $self->_select_or_examine($command, $mailbox)
-# Issue a SELECT or EXAMINE command for the $mailbox. (Always use
-# EXAMINE if the 'read-only' flag is set.) Upon success, change the
-# state to SELECTED, otherwise go back to AUTH.
+# Issue a SELECT or EXAMINE command for the $mailbox. Upon success,
+# change the state to SELECTED, otherwise go back to AUTH.
sub _select_or_examine($$$) {
my $self = shift;
my $command = shift;
@@ -1413,10 +1458,7 @@ sub _resp($$;$$$) {
if (s/\A\* //) {
if (s/\ABYE //) {
- foreach (qw/STDIN STDOUT/) {
- $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
- }
- exit 0;
+ undef $self;
}
elsif (s/\A(?:OK|NO|BAD) //) {
$self->_resp_text($_);
@@ -1449,14 +1491,16 @@ sub _resp($$;$$$) {
$callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
}
elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) {
- my ($delim, $flags) = ($2, $1);
- my @flags = defined $flags ? split(/ /, $flags) : ();
+ my ($delim, $attrs) = ($2, $1);
+ my @attrs = defined $attrs ? split(/ /, $attrs) : ();
my $mailbox = $self->_astring(\$_);
$self->panic($_) unless $_ eq '';
$mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
undef $delim if uc $delim eq 'NIL';
$delim =~ s/\A"(.*)"\Z/$1/ if defined $delim;
- $callback->($mailbox, $delim, @flags) if defined $callback and $cmd eq 'LIST';
+ $self->_update_cache_for($mailbox, DELIMITER => $delim);
+ $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs);
+ $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST';
}
elsif (s/\ASTATUS //) {
my $mailbox = $self->_astring(\$_);
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-11 09:02:21 +0000