diff options
| -rw-r--r-- | debian/control | 16 | ||||
| -rwxr-xr-x | imapsync | 48 | ||||
| -rw-r--r-- | imapsync.1 | 11 | ||||
| -rw-r--r-- | lib/Net/IMAP/Sync.pm | 130 |
4 files changed, 131 insertions, 74 deletions
diff --git a/debian/control b/debian/control index 55ab86d..d55aec7 100644 --- a/debian/control +++ b/debian/control @@ -13,12 +13,12 @@ Depends: ${misc:Depends}, ${perl:Depends}, libconfig-tiny-perl, libdbi-perl, libdbd-sqlite3-perl Recommends: libio-socket-ssl-perl Description: IMAP-to-IMAP synchronization program for QRESYNC-capable servers - IMAPSync is a synchronization program between two QRESYNC-capable (RFC 7162) - IMAP4rev1 servers. Other required IMAP capabilities are LIST-EXTENDED (RFC - 5258), LIST-STATUS (RFC 5819) and UIDPLUS (RFC 4315), in addition to which - LITERAL+ (RFC 2088) and MULTIAPPEND (RFC 3502) are recommended for performance - reasons. + imapsync performs stateful synchronization between two IMAP4rev1 servers. + Such synchronization is made possible by the QRESYNC extension from [RFC7162]; + for convenience reasons servers must also support LIST-EXTENDED [RFC5258], + LIST-STATUS [RFC5819] and UIDPLUS [RFC4315]. . - Furthermore if both servers support the NOTIFY capability (RFC 5465), it is - possible to keep the connection alive and be notified of new updates as soon - as they arrive. + Furthermore, while imapsync 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. @@ -280,15 +280,15 @@ sub check_delim($) { # Return true if $mailbox exists on $name sub mbx_exists($$) { my ($name, $mailbox) = @_; - my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox}; - return (defined $flags and !grep {lc $_ eq lc '\NonExistent'} @$flags) ? 1 : 0; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0; } # Return true if $mailbox is subscribed to on $name sub mbx_subscribed($$) { my ($name, $mailbox) = @_; - my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox}; - return (defined $flags and grep {lc $_ eq lc '\Subscribed'} @$flags) ? 1 : 0; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0; } @@ -408,13 +408,19 @@ my @MAILBOXES; $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}}; my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); - @MAILBOXES = keys %mailboxes; - @MAILBOXES = grep !/$CONF->{_}->{'ignore-mailbox'}/, @MAILBOXES - if defined $CONF->{_}->{'ignore-mailbox'}; + 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; + }; - foreach my $mailbox (@MAILBOXES) { check_delim($mailbox); # ensure that the delimiter match - my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; + push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs; $STH_GET_INDEX->execute($mailbox); my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); @@ -465,7 +471,7 @@ my @MAILBOXES; } my $subscribed = mbx_subscribed('local', $mailbox); $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{remote}->{client}->create($mailbox); + $IMAP->{remote}->{client}->create($mailbox, 1); $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed; $DBH->commit(); } @@ -477,7 +483,7 @@ my @MAILBOXES; } my $subscribed = mbx_subscribed('remote', $mailbox); $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{local}->{client}->create($mailbox); + $IMAP->{local}->{client}->create($mailbox, 1); $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed; $DBH->commit(); } @@ -492,15 +498,15 @@ undef $IMAP; # Get all cached states from the database. my $STH_GET_CACHE = $DBH->prepare(q{ - SELECT mailbox, m.idx as idx, - l.UIDVALIDITY as lUIDVALIDITY, l.UIDNEXT as lUIDNEXT, l.HIGHESTMODSEQ as lHIGHESTMODSEQ, - r.UIDVALIDITY as rUIDVALIDITY, r.UIDNEXT as rUIDNEXT, r.HIGHESTMODSEQ as rHIGHESTMODSEQ + 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 = ? }); @@ -987,8 +993,8 @@ sub wait_notifications(;$) { 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; - next unless grep { $_ eq $MAILBOX } @MAILBOXES; msg(undef, "Resuming interrupted sync for $MAILBOX"); my %lUIDs; @@ -1041,6 +1047,7 @@ while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { 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}, @@ -1061,7 +1068,7 @@ if (defined $COMMAND and $COMMAND eq '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))) { @@ -1104,4 +1111,7 @@ while(1) { wait_notifications(900); } -END { cleanup(); } +END { + $_->logout() foreach grep defined, ($lIMAP, $rIMAP); + cleanup(); +} @@ -210,7 +210,7 @@ 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 pattern above). +with children matching one of the \fIlist-mailbox\fR patterns above). This option is only available in the default section. .TP @@ -306,13 +306,14 @@ Authorities, used for server certificate verification. .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] \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/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 48f61c1..47c6258 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -380,7 +380,7 @@ sub new($%) { sub DESTROY($) { my $self = shift; foreach (qw/STDIN STDOUT/) { - $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); } } @@ -490,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; } @@ -503,35 +504,54 @@ sub noop($) { } -# $self->create($mailbox) -# $self->delete($mailbox) +# $self->create($mailbox, [$try]) +# $self->delete($mailbox, [$try]) # CREATE or DELETE $mailbox. -sub create($$) { - my ($self, $mailbox) = @_; - $self->_send("CREATE ".quote($mailbox)); - $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; +# 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->_send("DELETE ".quote($mailbox)); - $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; +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) +# $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 for the original name. -sub rename($$$) { - my ($self, $from, $to) = @_; - my $delim = $self->{_CACHE}->{$from}->{DELIMITER} if defined $self->{_CACHE}->{$from}; - $self->_send("RENAME ".quote($from).' '.quote($to)); - $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; +# 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) { + 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; @@ -539,21 +559,44 @@ sub rename($$$) { $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) +# $self->subscribe($mailbox, [$try]) +# $self->unsubscribe($mailbox, [$try]) # SUBSCRIBE or UNSUBSCRIBE $mailbox. -sub subscribe($$) { - my ($self, $mailbox) = @_; - $self->_send("SUBSCRIBE ".quote($mailbox)); - $self->log("Subscribed to mailbox ".$mailbox) unless $self->{quiet}; +# 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->_send("UNSUBSCRIBE ".quote($mailbox)); - $self->log("Unsubscribed to mailbox ".$mailbox) unless $self->{quiet}; +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; } @@ -1058,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; + } } @@ -1149,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; } @@ -1410,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($_); @@ -1446,15 +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; $self->_update_cache_for($mailbox, DELIMITER => $delim); - $callback->($mailbox, $delim, @flags) if defined $callback and $cmd eq 'LIST'; + $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(\$_); |