diff options
| author | Guilhem Moulin <guilhem@fripost.org> | 2015-07-25 18:56:19 +0200 | 
|---|---|---|
| committer | Guilhem Moulin <guilhem@fripost.org> | 2015-07-25 18:56:19 +0200 | 
| commit | dff9d2b460e543edad3726c3637145c2733515f8 (patch) | |
| tree | c2c88866a2fc3e2ef8c17ef4f14c86c90618b82c | |
| parent | 0cef7480d009ba721db43b3212f7b884fe95b8f8 (diff) | |
| parent | ea6122775d01460c3bf9f73bb7b15b5084623dfa (diff) | |
Merge branch 'master' into debian
| -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);                  }              }          } | 
