diff options
| -rwxr-xr-x | imapsync | 592 | ||||
| -rw-r--r-- | imapsync.1 | 273 | ||||
| -rw-r--r-- | imapsync.sample | 6 | ||||
| -rw-r--r-- | lib/Net/IMAP/Sync.pm | 245 |
4 files changed, 789 insertions, 327 deletions
@@ -1,7 +1,7 @@ #!/usr/bin/perl -T #---------------------------------------------------------------------- -# A minimal IMAP4 client for QRESYNC-capable servers +# IMAP-to-IMAP synchronization program for QRESYNC-capable servers # Copyright © 2015 Guilhem Moulin <guilhem@fripost.org> # # This program is free software: you can redistribute it and/or modify @@ -42,7 +42,7 @@ sub usage(;$) { print STDERR "TODO $NAME usage\n"; exit $rv; } -usage(1) unless GetOptions(\%CONFIG, qw/debug help|h config=s quiet|q oneshot|1 check/); +usage(1) unless GetOptions(\%CONFIG, qw/debug help|h config=s quiet|q oneshot|1 repair/); usage(0) if $CONFIG{help}; @@ -69,17 +69,16 @@ my ($DBFILE, $LOCKFILE); $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r; } -my ($DBH, $IMAP); - +my $DBH; # Clean after us -sub clean() { - print STDERR "Cleaning...\n" if $CONFIG{debug}; +sub cleanup() { + print STDERR "Cleaning up...\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/; +$SIG{$_} = sub { cleanup(); print STDERR "$!\n"; exit 1; } foreach qw/INT TERM/; +$SIG{$_} = sub { cleanup(); print STDERR "$!\n"; exit 0; } foreach qw/HUP/; ############################################################################# @@ -122,15 +121,15 @@ $DBH->do('PRAGMA foreign_keys = ON'); 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)} + q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially # one-to-one correspondence between local.idx and remote.idx ], remote => [ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)}, q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)}, - q{UIDNEXT UNSIGNED INT NOT NULL CHECK (UIDNEXT > 0)}, - q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)} + q{UIDNEXT UNSIGNED INT NOT NULL}, # 0 initially + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially # one-to-one correspondence between local.idx and remote.idx ], mapping => [ @@ -139,7 +138,7 @@ $DBH->do('PRAGMA foreign_keys = ON'); 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 + # also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT (except for interrupted syncs) # mapping.idx must be found among local.idx (and remote.idx) ], ); @@ -176,6 +175,7 @@ sub msg($@) { ############################################################################# # Connect to the local and remote IMAP servers +my $IMAP; foreach my $name (qw/local remote/) { my %config = %{$CONF->{$name}}; $config{$_} = $CONFIG{$_} foreach keys %CONFIG; @@ -406,7 +406,7 @@ sub sync_tree($$%) { 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); + die "Couldn't sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx); } } } @@ -531,8 +531,7 @@ my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? my $STH_GET_REMOTE_UID = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? and lUID = ?}); # Delete a (idx,lUID,rUID) association. -# /!\ Don't commit before the messages have actually been EXPUNGEd on -# both sides! +# /!\ Don't commit before the messages have actually been EXPUNGEd on both sides! my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?}); # Update the HIGHESTMODSEQ. @@ -544,129 +543,209 @@ 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_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 (?,?,?,?)}); +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)}); # Insert or retrieve a (idx,lUID,rUID) association. my $STH_INSERT_MAPPING = $DBH->prepare(q{INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)}); my $STH_GET_MAPPING = $DBH->prepare(q{SELECT lUID,rUID FROM mapping WHERE idx = ?}); +# Get the list of interrupted mailbox syncs. +my $STH_LIST_INTERRUPTED = $DBH->prepare(q{ + SELECT mbx.idx, mailbox + FROM mailboxes mbx JOIN local l ON mbx.idx = l.idx JOIN remote r ON mbx.idx = r.idx JOIN mapping ON mbx.idx = mapping.idx + WHERE (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT) + GROUP BY mbx.idx +}); + +# For an interrupted mailbox sync, get the pairs (lUID,rUID) that have +# already been downloaded. +my $STH_GET_INTERRUPTED_BY_IDX = $DBH->prepare(q{ + SELECT lUID, rUID + FROM mapping m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx + WHERE m.idx = ? AND (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT) +}); -# 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 => ($CONFIG{check} ? 0 : $row->{lHIGHESTMODSEQ}) - ); - $rIMAP->set_cache($row->{mailbox}, - UIDVALIDITY => $row->{rUIDVALIDITY}, - UIDNEXT => $row->{rUIDNEXT}, - HIGHESTMODSEQ => ($CONFIG{check} ? 0 : $row->{rHIGHESTMODSEQ}) - ); -} -# Download some missing UIDs. -sub fix_missing($$$@) { +# Download some missing UIDs from $source; returns the thew allocated UIDs +sub download_missing($$$@) { my $idx = shift; my $mailbox = shift; - my $name = shift; + my $source = shift; my @set = @_; + my @uids; + + my $target = $source eq 'local' ? 'remote' : 'local'; - my $source = $name eq 'local' ? $lIMAP : $rIMAP; - my $target = $name eq 'local' ? $rIMAP : $lIMAP; + my ($buff, $bufflen) = ([], 0); + undef $buff if ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND'); my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/; - $source->fetch(compact_set(@set), "($attrs)", sub(%) { - my %mail = @_; - return unless exists $mail{RFC822}; # not for us + ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) { + my $mail = shift; + return unless exists $mail->{RFC822}; # not for us - my $from = first { defined $_ and @$_ } @{$mail{ENVELOPE}}[2,3,4]; + my $uid = $mail->{UID}; + my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4]; $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : ''; - print STDERR "$name($mailbox): UID $mail{UID} from <$from> ($mail{INTERNALDATE})\n" unless $CONFIG{quiet}; + print STDERR "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})\n" unless $CONFIG{quiet}; - # don't bother checking for MULTIAPPEND, @set is probably rather small - my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE}); - my ($uid) = $target->append($mailbox, @mail); - - my ($lUID, $rUID) = $name eq 'local' ? ($mail{UID}, $uid) : ($uid, $mail{UID}); - print STDERR "$name($mailbox): Adding mapping (lUID,rUID) = ($lUID,$rUID)\n"; - $STH_INSERT_MAPPING->execute($idx, $lUID, $rUID); + callback_new_message($idx, $mailbox, $source, $mail, \@uids, $buff, \$bufflen) }); + push @uids, callback_new_message_flush($idx, $mailbox, $source, @$buff) if defined $buff and @$buff; + return @uids; +} + + +# Solve a flag update conflict (by taking the union of the two flag lists). +sub flag_conflict($$$$$) { + my ($mailbox, $lUID, $lFlags, $rUID, $rFlags); + + my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags)); + my $flags = join ' ', sort(keys %flags); + warn "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ". + "and remote UID $rUID ($rFlags). Setting both to the union ($flags).\n"; + + return $flags } -# Check synchronization of a mailbox between the two servers (in a very crude way) -my @CHECKED; -sub check($$$$$) { - my ($idx, $lVanished, $lList, $rVanished, $rList) = @_; + +# Delete a mapping ($idx, $lUID) +sub delete_mapping($$) { + my ($idx, $lUID) = @_; + my $r = $STH_DELETE_MAPPING->execute($idx, $lUID); + die if $r > 1; # sanity check + warn "WARNING: Can't delete (idx,lUID) = ($idx,$lUID) from the database\n" if $r == 0; +} + + +# 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) = @_; + + # get all existing UID with their flags + my ($lVanished, $lModified) = $lIMAP->pull_updates(1); + my ($rVanished, $rModified) = $rIMAP->pull_updates(1); my %lVanished = map {$_ => 1} @$lVanished; my %rVanished = map {$_ => 1} @$rVanished; + my (@lToRemove, %lToUpdate, @lMissing); + my (@rToRemove, %rToUpdate, @rMissing); + my @delete_mapping; + $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 - my $mailbox = $cache->{mailbox}; + + # process each pair ($lUID,$rUID) found in the mapping table, and + # compare with the result from the IMAP servers to detect anomalies $STH_GET_MAPPING->execute($idx); - my %missing = ( local => [], remote => [] ); while (defined (my $row = $STH_GET_MAPPING->fetch())) { my ($lUID, $rUID) = @$row; - if (defined $lList->{$lUID} and defined $rList->{$rUID}) { - # both $lUID and $rUID are known - if ($lList->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and - $rList->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) { - # old stuff - if ($lList->{$lUID}->[1] ne $rList->{$rUID}->[1]) { - warn "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Fixing...\n"; - # keep it in the hash references so we fix it automatically - } - else { - # no conflict, remove it from the hashes - delete $lList->{$lUID}; - delete $rList->{$rUID}; - } + if (defined $lModified->{$lUID} and defined $rModified->{$rUID}) { + # both $lUID and $rUID are known; see sync_known_messages + # for the sync algorithm + my ($lFlags, $rFlags) = ($lModified->{$lUID}->[1], $rModified->{$rUID}->[1]); + if ($lFlags eq $rFlags) { + # no conflict + } + elsif ($lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and + $rModified->{$rUID}->[0] > $cache->{rHIGHESTMODSEQ}) { + # set $lUID to $rFlags + $lToUpdate{$rFlags} //= []; + push @{$lToUpdate{$rFlags}}, $lUID; + } + elsif ($lModified->{$lUID}->[0] > $cache->{lHIGHESTMODSEQ} and + $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) { + # set $rUID to $lFlags + $rToUpdate{$lFlags} //= []; + push @{$rToUpdate{$lFlags}}, $rUID; } else { - # delete the old stuff - delete $lList->{$lUID} if $lList->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ}; - delete $rList->{$rUID} if $rList->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}; + # conflict + warn "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.\n" + if $lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and + $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}; + # set both $lUID and $rUID to the union of $lFlags and $rFlags + my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags); + $lToUpdate{$flags} //= []; + push @{$lToUpdate{$flags}}, $lUID; + $rToUpdate{$flags} //= []; + push @{$rToUpdate{$flags}}, $rUID; } } - elsif (!defined $lList->{$lUID} and !defined $rList->{$rUID}) { + elsif (!defined $lModified->{$lUID} and !defined $rModified->{$rUID}) { unless ($lVanished{$lUID} and $rVanished{$rUID}) { - # will be deleted from the database later - warn "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox\n"; - $lVanished{$lUID} = 1; - $rVanished{$rUID} = 1; + warn "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing.\n"; + push @delete_mapping, $lUID; } } - elsif (!defined $lList->{$lUID}) { - unless ($lVanished{$lUID}) { - warn "WARNING: local($mailbox): No match for remote UID $rUID. Downloading again...\n"; - push @{$missing{remote}}, $rUID; - delete $rList->{$rUID}; + elsif (!defined $lModified->{$lUID}) { + push @delete_mapping, $lUID; + if ($lVanished{$lUID}) { + push @rToRemove, $rUID; + } else { + warn "local($mailbox): WARNING: UID $lUID disappeared. Downloading remote UID $rUID again.\n"; + push @rMissing, $rUID; } } - elsif (!defined $rList->{$rUID}) { - unless ($rVanished{$rUID}) { - warn "WARNING: remote($mailbox): No match for local UID $lUID. Downloading again...\n"; - push @{$missing{local}}, $lUID; - delete $lList->{$lUID}; + elsif (!defined $rModified->{$rUID}) { + push @delete_mapping, $lUID; + if ($rVanished{$rUID}) { + push @lToRemove, $lUID; + } else { + warn "remote($mailbox): WARNING: UID $rUID disappeared. Downloading local UID $lUID again.\n"; + push @lMissing, $lUID; } } - $lList->{$lUID} = $lList->{$lUID}->[1] if defined $lList->{$lUID}; - $rList->{$rUID} = $rList->{$rUID}->[1] if defined $rList->{$rUID}; + + delete $lModified->{$lUID}; + delete $lVanished{$lUID}; + delete $rModified->{$rUID}; + delete $rVanished{$rUID}; } - # we'll complain later for modified UIDs without an entry in the database + # remove messages on the IMAP side; will increase HIGHESTMODSEQ + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@rToRemove) if @rToRemove; + + # remove entries in the table + delete_mapping($idx, $_) foreach @delete_mapping; + $DBH->commit() if @delete_mapping; - @$lVanished = keys %lVanished; - @$rVanished = keys %rVanished; - push @CHECKED, $idx; - return %missing; + # push flag updates; will increase HIGHESTMODSEQ + while (my ($lFlags,$lUIDs) = each %lToUpdate) { + $lIMAP->push_flag_updates($lFlags, @$lUIDs); + } + while (my ($rFlags,$rUIDs) = each %rToUpdate) { + $rIMAP->push_flag_updates($rFlags, @$rUIDs); + } + + + # Process UID found in IMAP but not in the mapping table. + warn "remote($mailbox): WARNING: No match for vanished local UID $_. Ignoring.\n" foreach keys %lVanished; + warn "local($mailbox): WARNING: No match for vanished remote UID $_. Ignoring.\n" foreach keys %rVanished; + + foreach my $lUID (keys %$lModified) { + warn "remote($mailbox): WARNING: No match for modified local UID $lUID. Downloading again.\n"; + push @lMissing, $lUID; + } + foreach my $rUID (keys %$rModified) { + warn "local($mailbox): WARNING: No match for modified remote UID $rUID. Downloading again.\n"; + push @rMissing, $rUID; + } + + # download missing UIDs; will increase UIDNEXT and HIGHESTMODSEQ + my @rIgnore = download_missing($idx, $mailbox, 'local', @lMissing) if @lMissing; + my @lIgnore = download_missing($idx, $mailbox, 'remote', @rMissing) if @rMissing; + + # download new messages; this will also update UIDNEXT and HIGHESTMODSEQ in the database + sync_messages($idx, $mailbox, \@lIgnore, \@rIgnore); } @@ -680,15 +759,13 @@ sub sync_known_messages($$) { # loop since processing might produce VANISHED or unsollicited FETCH responses while (1) { - my ($lVanished, $lModified, $rVanished, $rModified, %missing); + my ($lVanished, $lModified, $rVanished, $rModified); - my $check = ($CONFIG{check} and !grep { $idx == $_} @CHECKED) ? 1 : 0; - ($lVanished, $lModified) = $lIMAP->pull_updates($check); - ($rVanished, $rModified) = $rIMAP->pull_updates($check); - %missing = check($idx, $lVanished, $lModified, $rVanished, $rModified) if $check; + ($lVanished, $lModified) = $lIMAP->pull_updates(); + ($rVanished, $rModified) = $rIMAP->pull_updates(); # repeat until we have nothing pending - return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished or %missing; + return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished; $update = 1; # process VANISHED messages @@ -707,7 +784,7 @@ sub sync_known_messages($$) { my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check if (!defined $rUID) { - warn "WARNING: remote($mailbox): No match for local vanished UID $lUID. Ignoring...\n"; + warn "remote($mailbox): WARNING: No match for vanished local UID $lUID. Ignoring.\n"; } elsif (!exists $rVanished{$rUID}) { push @rToRemove, $rUID; @@ -718,21 +795,19 @@ sub sync_known_messages($$) { my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check if (!defined $lUID) { - warn "WARNING: local($mailbox): No match for remote vanished UID $rUID. Ignoring...\n"; + warn "local($mailbox): WARNING: No match for vanished remote UID $rUID. Ignoring.\n"; } elsif (!exists $lVanished{$lUID}) { push @lToRemove, $lUID; } } - $lIMAP->remove(@lToRemove) if @lToRemove; - $rIMAP->remove(@rToRemove) if @rToRemove; + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@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: Can't delete (idx,lUID) = ($idx,$lUID) from the database\n" if $r == 0; + delete_mapping($idx, $lUID); } } @@ -755,15 +830,11 @@ sub sync_known_messages($$) { my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check if (!defined $rUID) { - warn "WARNING: remote($mailbox): No match for local updated UID $lUID. Downloading again...\n"; - push @{$missing{local}}, $lUID; + warn "remote($mailbox): WARNING: No match for modified local UID $lUID. Try '--repair'.\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"; + my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags); $lToUpdate{$flags} //= []; push @{$lToUpdate{$flags}}, $lUID; $rToUpdate{$flags} //= []; @@ -780,8 +851,7 @@ sub sync_known_messages($$) { my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check if (!defined $lUID) { - warn "WARNING: local($mailbox): No match for remote updated UID $rUID. Downloading again...\n"; - push @{$missing{remote}}, $rUID; + warn "local($mailbox): WARNING: No match for modified remote UID $rUID. Try '--repair'.\n"; } elsif (!exists $lModified->{$lUID}) { # conflicts are taken care of above @@ -790,9 +860,6 @@ sub sync_known_messages($$) { } } - fix_missing($idx, $mailbox, 'local', @{$missing{local}}) if @{$missing{local} // []}; - fix_missing($idx, $mailbox, 'remote', @{$missing{remote}}) if @{$missing{remote} // []}; - while (my ($lFlags,$lUIDs) = each %lToUpdate) { $lIMAP->push_flag_updates($lFlags, @$lUIDs); } @@ -804,81 +871,99 @@ sub sync_known_messages($$) { } -# 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); +# The callback to use when FETCHing new messages from $name to add it to +# the other one. +# If defined, the array reference $UIDs will be fed with the newly added +# UIDs. +# If defined, $buff contains the list of messages to be appended with +# MULTIAPPEND. In that case callback_new_message_flush should be called +# after the FETCH. +sub callback_new_message($$$$;$$$) { + my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_; + return unless exists $mail->{RFC822}; # not for us + + my $length = length $mail->{RFC822}; + if ($length == 0) { + warn "$name($mailbox): WARNING: Ignoring new 0-length message (UID $mail->{UID})\n"; + return; + } - # don't fetch again the messages we've just added - my @ignore = $source eq 'local' ? keys %mapping : values %mapping; + my @UIDs; + unless (defined $buff) { + @UIDs = callback_new_message_flush($idx, $mailbox, $name, $mail); + } + else { + # use MULTIAPPEND (RFC 3502) + # proceed by batches of 1MB to save roundtrips without blowing up the memory + if (@$buff and $$bufflen + $length > 1048576) { + @UIDs = callback_new_message_flush($idx, $mailbox, $name, @$buff); + @$buff = (); + $$bufflen = 0; + } + push @$buff, $mail; + $$bufflen += $length; + } + push @$UIDs, @UIDs if defined $UIDs; +} - ($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}; +# Add the given @messages (multiple messages are only allowed for +# MULTIAPPEND-capable servers) from $name to the other server. +# Returns the list of newly allocated UIDs. +sub callback_new_message_flush($$$@) { + my ($idx, $mailbox, $name, @messages) = @_; - # use MULTIAPPEND if possible (RFC 3502) to save round-trips - $multiappend //= !$target->incapable('MULTIAPPEND'); + my $imap = $name eq 'local' ? $rIMAP : $lIMAP; # target client + my @sUID = map {$_->{UID}} @messages; + my @tUID = $imap->append($mailbox, @messages); + die unless $#sUID == $#tUID; # sanity check - 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; - } + my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID); + for (my $k=0; $k<=$#messages; $k++) { + print STDERR "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox\n" + if $CONFIG{debug}; + $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]); } + $DBH->commit(); # commit only once per batch - # 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, $mailbox); - $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, $mailbox); - $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $$idx); - $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $$idx); - } + return @tUID; +} - while (my ($lUID,$rUID) = each %mapping) { - $STH_INSERT_MAPPING->execute($$idx, $lUID, $rUID); - } + +# Sync both known and new messages +# If the array references $lIgnore and $rIgnore are not empty, skip +# the given UIDs. +sub sync_messages($$;$$) { + my ($idx, $mailbox, $lIgnore, $rIgnore) = @_; + my ($buff, $bufflen, @lUIDs); + + # get new messages from remote (except @$rIgnore) and APPEND them to local + ($buff, $bufflen) = ([], 0); + undef $buff if $lIMAP->incapable('MULTIAPPEND'); + $rIMAP->pull_new_messages(sub($) { + callback_new_message($idx, $mailbox, 'remote', shift, \@lUIDs, $buff, \$bufflen) + }, @{$rIgnore // []}); + push @lUIDs, callback_new_message_flush($idx, $mailbox, 'remote', @$buff) + if defined $buff and @$buff; + + # get new messages from local (except @$lIgnore and the newly allocated local + # UIDs @lUIDs) and APPEND them to remote + ($buff, $bufflen) = ([], 0); + undef $buff if $rIMAP->incapable('MULTIAPPEND'); + $lIMAP->pull_new_messages(sub($) { + callback_new_message($idx, $mailbox, 'local', shift, undef, $buff, \$bufflen) + }, @{$lIgnore // []}, @lUIDs); + callback_new_message_flush($idx, $mailbox, 'local', @$buff) + if defined $buff and @$buff; + + # both local and remote UIDNEXT are now up to date; proceed with + # pending flag updates and vanished messages + sync_known_messages($idx, $mailbox); + + # don't store the new UIDNEXTs before to avoid downloading these + # mails again in the event of a crash + $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $idx); + $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $idx); $DBH->commit(); } @@ -903,39 +988,140 @@ sub wait_notifications(;$) { } -my ($mailbox, $idx); +# Resume interrupted mailbox syncs. +my ($MAILBOX, $IDX); +$STH_LIST_INTERRUPTED->execute(); +while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { + ($IDX, $MAILBOX) = @$row; + print STDERR "Resuming interrupted sync for $MAILBOX\n"; + + my %lUIDs; + $STH_GET_INTERRUPTED_BY_IDX->execute($IDX); + while (defined (my $row = $STH_GET_INTERRUPTED_BY_IDX->fetchrow_arrayref())) { + $lUIDs{$row->[0]} = $row->[1]; # pair ($lUID, $rUID) + } + die unless %lUIDs; # sanity check + + $lIMAP->select($MAILBOX); + $rIMAP->select($MAILBOX); + + # FETCH all messages with their FLAGS to detect messages that have + # vanished meanwhile, or for which there was a flag update. + + my (%lList, %rList); # The lists of existing local and remote UIDs + my $attrs = '('.join(' ', qw/MODSEQ FLAGS/).')'; + $lIMAP->fetch(compact_set(keys %lUIDs), $attrs, sub($){ $lList{shift->{UID}} = 1 }); + $rIMAP->fetch(compact_set(values %lUIDs), $attrs, sub($){ $rList{shift->{UID}} = 1 }); + + my (@lToRemove, @rToRemove); + while (my ($lUID,$rUID) = each %lUIDs) { + next if $lList{$lUID} and $rList{$rUID}; # exists on both + push @lToRemove, $lUID if $lList{$lUID}; + push @rToRemove, $rUID if $rList{$rUID}; + + delete_mapping($IDX, $lUID); + } + + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@rToRemove) if @rToRemove; + $DBH->commit() if @lToRemove or @rToRemove; # /!\ commit *after* remove_message! + + # ignore deleted messages + delete @lList{@lToRemove}; + delete @rList{@rToRemove}; + + # Resume the sync, but skip messages that have already been + # downloaded. Flag updates will be processed automatically since + # the _MODIFIED internal cache has been initialized with all our + # UIDs. (Since there is no reliable HIGHESTMODSEQ, any flag + # difference is treated as a conflict.) + sync_messages($IDX, $MAILBOX, [keys %lList], [keys %rList]); +} + + + +# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness. +$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} + ); + push @REPAIR, $row->{mailbox} if $CONFIG{repair} and + (!@ARGV or grep { $_ eq $row->{mailbox} } @ARGV); +} + +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 ($CONFIG{repair}) { + cleanup(); + exit 0; +} + + 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); + 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 + $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(); + $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); + $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 - # sync updates to known messages before fetching new messages - if (defined $idx and sync_known_messages($idx, $mailbox)) { + $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) + } + elsif (sync_known_messages($IDX, $MAILBOX)) { + # sync updates to known messages before fetching new messages # get_cache is safe after pull_update - $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $idx); - $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $idx); + $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); + sync_messages($IDX, $MAILBOX); } } # clean state! - exit 0 if $CONFIG{oneshot} or $CONFIG{check}; + if ($CONFIG{oneshot}) { + cleanup(); + exit 0; + } wait_notifications(900); } -END { clean (); } +END { cleanup(); } diff --git a/imapsync.1 b/imapsync.1 new file mode 100644 index 0000000..eda493a --- /dev/null +++ b/imapsync.1 @@ -0,0 +1,273 @@ +.TH IMAPSYNC "1" "JULY 2015" "imapsync" "User Commands" + +.SH NAME +imapsync \- IMAP-to-IMAP synchronization program for QRESYNC-capable servers + +.SH SYNOPSIS +.B imapsync\fR [\fIOPTION\fR ...] [\fIMAILBOX\fR ...] + + +.SH DESCRIPTION +.PP +.B imapsync\fR performs stateful synchronization between two IMAP4rev1 +servers, then (unless the flag \fB\-\-oneshot\fR is set) keeps both +connection open and wait for new changes to arrive. +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. + +.PP +Stateful synchronization is only possible for mailboxes supporting +persistent message Unique Identifiers (UID) and persistent storage of +mod\-sequences (MODSEQ); any non\-compliant mailbox will cause +\fBimapsync\fR to abort. +Furthermore, because UIDs are allocated not by the client but by the +server, \fBimapsync\fR needs to keep track of associations between local +and remote UIDs for each mailbox. +The synchronization state of a mailbox consists of its UIDNEXT and +HIGHESTMODSEQ values on each server; +it is then assumed that each message with UID < $UIDNEXT have been +replicated to the other server, and that the metadata (such as flags) of +each message with MODSEQ <= $HIGHESTMODSEQ have been synchronized. +Conceptually, the synchronization algorithm is derived from [RFC4549] +with the [RFC7162, section 6.1] amendments, and works as follows: + +.nr step 1 1 +.IP \n[step]. 8 +SELECT (on both servers) a mailbox the current UIDNEXT or HIGHESTMODSEQ +values of which differ from the values found in the database (for either +server). Use the QRESYNC SELECT parameter from [RFC7162] to list +changes (vanished messages and flag updates) since $HIGHESTMODSEQ to +messages with UID<$UIDNEXT. + +.IP \n+[step]. +Propagate these changes onto the other server: get the corresponding +UIDs from the database, then a/ issue an UID STORE + UID EXPUNGE command +to remove messages that have not already been deleted on both servers, +and /b issue UID STORE commands to propagate flag updates (send a single +command for each flag list in order the reduce the number of round +trips). +(Conflicts may occur if the metadata of a message has been updated on +both servers with different flag lists; in that case \fBimapsync\fR +issues a warning and updates the message on each server with the union +of both flag lists.) +Repeat this step if the server sent some updates in the meantime. +Otherwise, update the HIGHESTMODSEQ values in the database. + +.IP \n+[step]. +Process new messages (if the current UIDNEXT value differ from the one +found in the database) by issuing an UID FETCH command and for each +message RFC822 body received, issue an APPEND command to the other +server on\-the\-fly. +Repeat this step if the server received new messages in the meantime. +Otherwise, update the UIDNEXT values in the database. +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. + +.PP +By default \fBimapsync\fR synchronizes each subscribed mailbox; +providing extra arguments limits the synchronization to the given +\fIMAILBOX\fRes only. + +.PP +In its default mode (unless the flag \fB\-\-oneshot\fR or +\fB\-\-repair\fR is set), \fBimapsync\fR does not exit once all +mailboxes have been synchronized. Instead, it keeps both connection +open and uses the NOTIFY command from [RFC5465] to be notified of new +changes (on any mailbox) as soon as they arrive. If no update is sent +in 15 minutes, a NOOP command is issued in order not to trigger the +servers' inactivity timeout and be logged out. + +.PP +If the synchronization was interrupted during a previous run while some +messages were being replicated (but before the UIDNEXT or HIGHESTMODSEQ +values have been updated), \fBimapsync\fR performs a \(lqfull +synchronization\(rq on theses messages only: +downloading the whole UID and flag lists on each servers allows +\fBimapsync\fR to detect messages that have been removed or for which +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. + +.TP +.B \-1\fR, \fB\-\-oneshot\fR +Exit as soon as all mailboxes are synchronized, instead of passively +waiting for updates from the open connections. +Using \fB\-\-oneshot\fR removes the requirement that IMAP servers must +advertise support the NOTIFY extension [RFC5465]. + +.TP +.B \-\-repair +List the database anomalies and try to repair them. +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 +to an existing UID, and 3/ ensure that both flag lists match. +Any message found on a server but not in the database is replicated on +the other server (which in the worst case, might lead to a message +duplicate). +Flag conflicts are solved by updating each message to the union of both +lists. + +.TP +.B \-q\fR, \fB\-\-quiet\fR +Try to be quiet. + +.TP +.B \-\-debug +Turn on debug mode. +Note that all IMAP traffic (excluding literals) is then printed to the +error output. Depending on the chosen authentication mechanism, +this might include authentication credentials. + +.TP +.B \-h\fR, \fB\-\-help\fR +Output a brief help and exit. + +.TP +.B \-\-version +Show the version number and exit. + +.SH CONFIGURATION FILE + +Unless told otherwise by the \fB\-\-config=\fR\fIFILE\fR option, +\fBimapsync\fR reads its configuration from +\fI$XDG_CONFIG_HOME/imapsync\fR (or \fI~/.config/imapsync\fR if the +XDG_CONFIG_HOME environment variable is unset) as an INI file. +The syntax of the configuration file is a serie of +\fIOPTION\fR=\fIVALUE\fR lines organized under some \fI[SECTION]\fR; +lines starting with a \(oq#\(cq or \(oq;\(cq character are ignored as +comments. +The sections \(lq[local]\(rq and \(lq[remote]\(rq define the two IMAP +servers to synchronize. +Valid options are: + +.TP +.I database +SQLite version 3 database file to use to keep track of associations +between local and remote UIDs, as well as the UIDVALIDITY, UIDNEXT and +HIGHESTMODSEQ of each known mailbox on both servers. +Relative paths start from \fI$XDG_DATA_HOME/imapsync\fR, or +\fI~/.local/share/imapsync\fR if the XDG_DATA_HOME environment variable +is unset. +This option is only available in the default section. +(Default: \(lq\fIhost\fR.db\)\(rq, where \fIhost\fR is taken from the +\(lq[remote]\(rq or \(lq[local]\(rq sections, in that order. + +.TP +.I type +One of \(lqimap\(rq, \(lqimaps\(rq or \(lqtunnel\(rq. +\fItype\fR=imap and \fItype\fR=imaps are respectively used for IMAP and +IMAP over SSL/TLS connections over a INET socket. +\fItype\fR=tunnel causes \fBimapsync\fR to open a pipe to a +\fIcommand\fR instead of a raw socket. +(Default: \(lqimaps\(rq.) + +.TP +.I host +Server hostname, for \fItype\fR=imap and \fItype\fR=imaps. +(Default: \(lqlocalhost\(rq.) + +.TP +.I port +Server port. +(Default: \(lq143\(rq for \fItype\fR=imap, \(lq993\(rq for +\fItype\fR=imaps.) + +.TP +.I command +Command to use for \fItype\fR=tunnel. Must speak the IMAP4rev1 protocol +on its standard output, and understand it on its standard input. + +.TP +.I STARTTLS +Whether to use the \(lqSTARTTLS\(rq directive to upgrade a secure +connection. Setting this to \(lqYES\(rq for a server not advertising +the \(lqSTARTTLS\(rq capability causes \fBimapsync\fR to immediately +abort the connection. +(Ignored for \fItype\fRs other than \(lqimap\(rq. Default: \(lqYES\(rq.) + +.TP +.I auth +Space\-separated list of preferred authentication mechanisms. +\fBimapsync\fR uses the first mechanism in that list that is also +advertised (prefixed with \(lqAUTH=\(rq) in the server's capability list. +Supported authentication mechanisms are \(lqPLAIN\(rq and \(lqLOGIN\(rq. +(Default: \(lqPLAIN LOGIN\(rq.) + +.TP +.I username\fR, \fIpassword\fR +Username and password to authenticate with. Can be required for non +pre\-authenticated connections, depending on the chosen authentication +mechanism. + +.TP +.I SSL_cipher_list +Cipher list to use for the connection. +See \fIciphers\fR(1ssl) for the format of such list. + +.TP +.I SSL_fingerprint +Fingerprint of the server certificate in the form +\fIALGO\fR$\fIDIGEST_HEX\fR, where \fIALGO\fR is the used algorithm +(default \(lqsha256\(rq). +Attempting to connect to a server with a non-matching certificate +fingerprint causes \fBimapsync\fR to abort the connection immediately +after the SSL/TLS handshake. + +.TP +.I SSL_verify_trusted_peer +Whether to verify that the peer certificate has been signed by a trusted +Certificate Authority. Note that using \fISSL_fingerprint\fR to specify +the fingerprint of the server certificate is orthogonal and does not +rely on Certificate Authorities. +(Default: \(lqYES\(rq.) + +.TP +.I SSL_ca_path +Directory containing the certificate(s) of the trusted Certificate +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] +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. +.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 +[RFC6851] or COPY + STORE + EXPUNGE), moving a messages causes +\fBimapsync\fR to believe that it was deleted while another one (which +is replicated again) was added to the other mailbox in the meantime. + +.IP \[bu] +\(lqPLAIN\(rq and \(lqLOGIN\(rq are the only authentication mechanisms +currently supported. + +.SH AUTHOR +Guilhem Moulin <guilhem@fripost.org> diff --git a/imapsync.sample b/imapsync.sample index 51958aa..e563e94 100644 --- a/imapsync.sample +++ b/imapsync.sample @@ -1,7 +1,7 @@ ; database = imap.guilhem.org.db [local] -type = preauth +type = tunnel command = /usr/lib/dovecot/imap [remote] @@ -12,9 +12,9 @@ username = guilhem password = xxxxxxxxxxxxxxxx ; SSL options -;SSL_verify_peer = TRUE -SSL_ca_path = /etc/ssl/certs ;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 diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index bb99dcb..9db339b 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -39,17 +39,17 @@ my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; my %OPTIONS = ( host => qr/\A([0-9a-zA-Z:.-]+)\z/, port => qr/\A([0-9]+)\z/, - type => qr/\A(imaps?|preauth)\z/, - STARTTLS => qr/\A(true|false)\z/i, + type => qr/\A(imaps?|tunnel)\z/, + STARTTLS => qr/\A(YES|NO)\z/i, username => qr/\A([\x01-\x7F]+)\z/, 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(TRUE|FALSE)\z/i, - SSL_ca_path => qr/\A(\P{Control}+)\z/, - SSL_cipher_list => qr/\A(\P{Control}+)\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_verify_peer => qr/\A(TRUE|FALSE)\z/i, + SSL_cipher_list => qr/\A(\P{Control}+)\z/, + SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i, + SSL_ca_path => qr/\A(\P{Control}+)\z/, ); @@ -75,7 +75,7 @@ sub read_config($$%) { my %configs; foreach my $section (@$sections) { - my $conf = { %{$h->{_}} }; # default section + my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section $configs{$section} = $conf; next unless defined $section and $section ne '_'; @@ -87,7 +87,7 @@ sub read_config($$%) { $conf->{host} //= 'localhost'; $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef; $conf->{auth} //= 'PLAIN LOGIN'; - $conf->{STARTTLS} //= 'TRUE'; + $conf->{STARTTLS} //= 'YES'; # untaint and validate the config foreach my $k (keys %$conf) { @@ -203,7 +203,7 @@ our $IMAP_text; # # - 'enable': An extension or array reference of extensions to ENABLE # (RFC 5161) after entering AUTH state. Croak if the server did not -# advertize "ENABLE" in its CAPABILITY list or does not reply with +# advertise "ENABLE" in its CAPABILITY list or does not reply with # an untagged ENABLED response with all the given extensions. # # - 'STDERR': Where to log debug and informational messages (default: @@ -225,7 +225,7 @@ sub new($%) { bless $self, $class; # whether we're allowed to to use read-write command - $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1; + $self->{'read-only'} = uc ($self->{'read-only'} // 'NO') ne 'YES' ? 0 : 1; # where to log $self->{STDERR} //= \*STDERR; @@ -234,10 +234,10 @@ sub new($%) { # (cf RFC 3501 section 3) $self->{_STATE} = ''; - if ($self->{type} eq 'preauth') { + if ($self->{type} eq 'tunnel') { require 'IPC/Open2.pm'; - my $command = $self->{command} // $self->fail("Missing preauth command"); - my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, split(/ /, $command)) + my $command = $self->{command} // $self->fail("Missing tunnel command"); + my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, $command) or $self->panic("Can't fork: $!"); } else { @@ -252,8 +252,8 @@ sub new($%) { } else { require 'IO/Socket/SSL.pm'; - if (defined (my $vrfy = delete $self->{SSL_verify_peer})) { - $args{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE'; + if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { + $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; } my $fpr = delete $self->{SSL_fingerprint}; $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; @@ -311,16 +311,16 @@ sub new($%) { $self->{_STATE} = 'UNAUTH'; my @caps = $self->capabilities(); - if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'FALSE') { # RFC 2595 section 5.1 - $self->fail("Server did not advertize STARTTLS capability.") + if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1 + $self->fail("Server did not advertise STARTTLS capability.") unless grep {$_ eq 'STARTTLS'} @caps; require 'IO/Socket/SSL.pm'; $self->_send('STARTTLS'); my %sslargs; - if (defined (my $vrfy = delete $self->{SSL_verify_peer})) { - $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE'; + if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { + $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; } my $fpr = delete $self->{SSL_fingerprint}; $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; @@ -373,10 +373,10 @@ sub new($%) { : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}} : ($self->{enable}); if (@extensions) { - $self->fail("Server did not advertize ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); + $self->fail("Server did not advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); $self->_send('ENABLE '.join(' ',@extensions)); my @enabled = @{$self->{_ENABLED} // []}; - $self->fail("Could not ENABLE $_") foreach + $self->fail("Couldn't ENABLE $_") foreach grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; } @@ -387,8 +387,9 @@ sub new($%) { # Close handles when the Net::IMAP::Sync object is destroyed. sub DESTROY($) { my $self = shift; - foreach (qw/STDIN STDOUT/) { - $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + if (defined $self->{STDIN} and $self->{STDIN}->opened() and + defined $self->{STDOUT} and $self->{STDOUT}->opened()) { + $self->logout(); } $self->{STDERR}->close() if defined $self->{STDERR} and $self->{STDERR}->opened() and $self->{STDERR} ne \*STDERR; @@ -450,7 +451,7 @@ sub capabilities($) { # $self->incapable(@capabilities) # In list context, return the list capabilties from @capabilities -# which were NOT advertized by the server. In scalar context, return +# which were NOT advertised by the server. In scalar context, return # the length of said list. sub incapable($@) { my ($self, @caps) = @_; @@ -567,16 +568,16 @@ sub list($$@) { } -# $self->remove($uid, [...]) -# Remove the given $uid list. Croak if the server did not advertize +# $self->remove_message($uid, [...]) +# Remove the given $uid list. Croak if the server did not advertise # "UIDPLUS" (RFC 4315) in its CAPABILITY list. # Successfully EXPUNGEd UIDs are removed from the pending VANISHED and # MODIFIED lists. -# Return the list of UIDs that could not be EXPUNGEd. -sub remove($@) { +# Return the list of UIDs that couldn't be EXPUNGEd. +sub remove_message($@) { my $self = shift; my @set = @_; - $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.") + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") if $self->incapable('UIDPLUS'); my $set = compact_set(@set); @@ -599,37 +600,37 @@ sub remove($@) { delete @{$self->{_MODIFIED}}{@expunged}; $self->{_VANISHED} = [ keys %vanished ]; - $self->log("Removed UID ".compact_set(@expunged)) if @expunged and !$self->{quiet}; - $self->warn("Could not UID EXPUNGE ".compact_set(@failed)) if @failed; + $self->log("Removed ".($#expunged+1)." message(s), ". + "UID ".compact_set(@expunged)) if @expunged and !$self->{quiet}; + $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed; return @failed; } -# $self->append($mailbox, RFC822, [FLAGS, [INTERNALDATE, ...]]) +# $self->append($mailbox, $mail, [...]) # Issue an APPEND command with the given mails. Croak if the server -# did not advertize "UIDPLUS" (RFC 4315) in its CAPABILITY list. -# Providing multiple mails is only allowed for servers advertizing +# did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list. +# Providing multiple mails is only allowed for servers advertising # "MULTIAPPEND" (RFC 3502) in their CAPABILITY list. # Return the list of UIDs allocated for the new messages. -sub append($$$@) { +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 advertize UIDPLUS (RFC 4315) capability.") + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") if $self->incapable('UIDPLUS'); my @appends; - while (@_) { - my $rfc822 = shift; - my $flags = shift; - my $internaldate = shift; + foreach my $mail (@_) { my $append = ''; - $append .= '('.join(' ',@$flags).') ' if defined $flags; - $append .= '"'.$internaldate.'" ' if defined $internaldate; - $append .= "{".length($rfc822)."}\r\n".$rfc822; + $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' + if defined $mail->{FLAGS}; + $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; + $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822}; push @appends, $append; } - $self->fail("Server did not advertize MULTIAPPEND (RFC 3502) capability.") + $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.") if $#appends > 0 and $self->incapable('MULTIAPPEND'); # dump the cache before issuing the command if we're appending to the current mailbox @@ -649,12 +650,12 @@ sub append($$$@) { my @uids; foreach (split /,/, $uidset) { if (/\A([0-9]+)\z/) { - $UIDNEXT = $1 + 1 if $UIDNEXT < $1; + $UIDNEXT = $1 + 1 if $UIDNEXT <= $1; push @uids, $1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1); push @uids, ($min .. $max); - $UIDNEXT = $max + 1 if $UIDNEXT < $max; + $UIDNEXT = $max + 1 if $UIDNEXT <= $max; } else { $self->panic($_); } @@ -670,7 +671,7 @@ sub append($$$@) { delete $vanished2{$_} foreach keys %vanished; my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS; - $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 0) < $UIDNEXT; + $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT; } $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) @@ -691,10 +692,10 @@ sub fetch($$$$) { # $self->notify(@specifications) # Issue a NOTIFY command with the given mailbox @specifications (cf RFC # 5465 section 6) to be monitored. Croak if the server did not -# advertize "NOTIFY" (RFC 5465) in its CAPABILITY list. +# advertise "NOTIFY" (RFC 5465) in its CAPABILITY list. sub notify($@) { my $self = shift; - $self->fail("Server did not advertize NOTIFY (RFC 5465) capability.") + $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.") if $self->incapable('NOTIFY'); my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/; # Be notified of new messages with EXISTS/RECENT responses, but @@ -794,8 +795,8 @@ sub get_cache($@) { unless $self->{_STATE} eq 'SELECTED'; my $mailbox = $self->{_SELECTED} // $self->panic(); - $self->fail("Pending VANISHED responses!") if @{$self->{_VANISHED}}; - $self->fail("Pending FLAG updates!") if %{$self->{_MODIFIED}}; + $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; + $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}}; my $cache = $self->{_PCACHE}->{$mailbox}; return @_ ? @$cache{@_} : %$cache; @@ -851,42 +852,36 @@ sub pull_updates($;$) { my $mailbox = $self->{_SELECTED} // $self->panic(); my $pcache = $self->{_PCACHE}->{$mailbox}; - my (@vanished, %modified); - unless (defined $pcache->{UIDNEXT} and defined $pcache->{HIGHESTMODSEQ}) { - $self->{_MODIFIED} = {}; - $self->{_VANISHED} = []; - } - else { - $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") - if $full and $pcache->{UIDNEXT} > 1; - - my @missing; - while (%{$self->{_MODIFIED}}) { - while (my ($uid,$v) = each %{$self->{_MODIFIED}}) { - # don't filter on the fly (during FETCH responses) because - # FLAG updates can arrive while processing pull_new_messages - # for instance - if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH - next unless $uid < $pcache->{UIDNEXT} # out of bounds - and ($full or $v->[0] > $pcache->{HIGHESTMODSEQ}); # already seen - $modified{$uid} = $full ? $v : $v->[1]; - } else { - push @missing, $uid; - } + my %modified; + $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") + if $full and ($pcache->{UIDNEXT} // 1) > 1; + + my @missing; + while (%{$self->{_MODIFIED}}) { + while (my ($uid,$v) = each %{$self->{_MODIFIED}}) { + # don't filter on the fly (during FETCH responses) because + # FLAG updates can arrive while processing pull_new_messages + # for instance + if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH + next unless $uid < ($pcache->{UIDNEXT} // 1) # out of bounds + and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen + $modified{$uid} = $full ? $v : $v->[1]; + } else { + push @missing, $uid; } - $self->{_MODIFIED} = {}; - $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; - @missing = (); } + $self->{_MODIFIED} = {}; + $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; + @missing = (); + } - # do that afterwards since the UID FETCH command above can produce VANISHED responses - my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; - @vanished = keys %vanished; - $self->{_VANISHED} = []; + # do that afterwards since the UID FETCH command above can produce VANISHED responses + my %vanished = map {$_ => 1} grep { $_ < ($pcache->{UIDNEXT} // 1) } @{$self->{_VANISHED}}; + my @vanished = keys %vanished; + $self->{_VANISHED} = []; - # ignore FLAG updates on VANISHED messages - delete @modified{@vanished}; - } + # ignore FLAG updates on VANISHED messages + delete @modified{@vanished}; # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT # since there might be new messages) @@ -915,36 +910,43 @@ sub pull_new_messages($$@) { my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]'; my $mailbox = $self->{_SELECTED} // $self->panic(); - my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; - - my $range = ''; - my $first; - foreach my $uid (@ignore) { - if ($since < $uid) { - $first //= $since; - $range .= ',' if $range ne ''; - $range .= $since; - $range .= ':'.($uid-1) if $since < $uid-1; - $since = $uid+1; - } - elsif ($since == $uid) { - $since++; - } - } - - $first //= $since; - $range .= ',' if $range ne ''; - # 2^32-1: don't use '*' since the highest UID can be known already - $range .= "$since:4294967295"; - - my $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT}; - $self->panic() unless defined $UIDNEXT and $UIDNEXT > 0; # sanity check - $self->_send("UID FETCH $range ($attrs)", $callback) if $first < $UIDNEXT;; + my $UIDNEXT; + do { + my $range = ''; + my $first; + my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; + foreach my $uid (@ignore) { + if ($since < $uid) { + $first //= $since; + $range .= ',' if $range ne ''; + $range .= $since; + $range .= ':'.($uid-1) if $since < $uid-1; + $since = $uid+1; + } + elsif ($since == $uid) { + $since++; + } + } - # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ - # since there might be pending updates) - $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{UIDNEXT}); + $first //= $since; + $range .= ',' if $range ne ''; + # 2^32-1: don't use '*' since the highest UID can be known already + $range .= "$since:4294967295"; + + $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT} // $self->panic(); # sanity check + $self->_send("UID FETCH $range ($attrs)", sub($) { + my $mail = shift; + $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID}; + $callback->($mail) if defined $callback; + }) if $first < $UIDNEXT; + + # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ + # since there might be pending updates) + $self->set_cache($mailbox, UIDNEXT => $UIDNEXT); + } + # loop if new messages were received in the meantime + while ($UIDNEXT < $self->{_CACHE}->{$mailbox}->{UIDNEXT}); } @@ -963,7 +965,7 @@ sub push_flag_updates($$@) { my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; my %listed; - $self->_send($command, sub(%) { my %mail = @_; $listed{$mail{UID}}++; }); + $self->_send($command, sub($){ $listed{shift->{UID}}++; }); my %failed; if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { @@ -1211,10 +1213,10 @@ sub _select_or_examine($$$) { $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " ."1:".($pcache->{UIDNEXT}-1)."))" if $self->_enabled('QRESYNC') and - ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 0) > 1; + ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1; if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { - # A mailbox is currently selected and the server advertizes + # A mailbox is currently selected and the server advertises # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox # selection until the [CLOSED] response code has been received: # all responses before the [CLOSED] response code refer to the @@ -1394,6 +1396,9 @@ sub _resp($$;$$$) { if (s/\A\* //) { if (s/\ABYE //) { + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + } exit 0; } elsif (s/\A(?:OK|NO|BAD) //) { @@ -1456,7 +1461,7 @@ sub _resp($$;$$$) { # always present, cf RFC 3501 section 6.4.8 $mail{UID} = $1; # the actual UIDNEXT is *at least* that - $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} < $1; + $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} <= $1; } if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC # always present in unsolicited FETCH responses if QRESYNC has been enabled @@ -1487,7 +1492,7 @@ sub _resp($$;$$$) { my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS}; $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ]; } - $callback->(%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set); + $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set); } elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE $self->{_ENABLED} //= []; @@ -1502,15 +1507,13 @@ sub _resp($$;$$$) { if (/\A([0-9]+)\z/) { $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that - push @{$self->{_VANISHED}}, $1 - if defined $pcache->{UIDNEXT} and $1 < $pcache->{UIDNEXT}; + push @{$self->{_VANISHED}}, $1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that - push @{$self->{_VANISHED}}, grep {$_ < $pcache->{UIDNEXT}} ($min .. $max) - if defined $pcache->{UIDNEXT}; + push @{$self->{_VANISHED}}, ($min .. $max); } } } |