}
my @COMMANDS = qw/repair delete rename/;
-usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h watch:i/, @COMMANDS);
+usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h watch:i notify/, @COMMANDS);
usage(0) if $CONFIG{help};
my $COMMAND = do {
my @command = grep {exists $CONFIG{$_}} @COMMANDS;
$command[0]
};
usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or ($COMMAND eq 'rename' and $#ARGV != 1));
-usage(1) if defined $COMMAND and defined $CONFIG{watch};
+usage(1) if defined $COMMAND and (defined $CONFIG{watch} or defined $CONFIG{notify});
usage(1) if $CONFIG{target} and !(defined $COMMAND and ($COMMAND eq 'delete'or $COMMAND eq 'rename'));
-$CONFIG{watch} = 60 if defined $CONFIG{watch} and $CONFIG{watch} == 0;
+$CONFIG{watch} = $CONFIG{notify} ? 900 : 60 unless $CONFIG{watch};
@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive
die "Invalid mailbox name $_" foreach grep !/\A([\x01-\x7F]+)\z/, @ARGV;
my $LIST = '"" ';
my @LIST_PARAMS;
+my %LIST_PARAMS_STATUS = (STATUS => [qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/]);
if (!defined $COMMAND or $COMMAND eq 'repair') {
$LIST = '('.uc($CONF->{_}->{'list-select-opts'}).') '.$LIST if defined $CONF->{_}->{'list-select-opts'};
$LIST .= (defined $CONF->{_}->{'list-mailbox'} ? '('.$CONF->{_}->{'list-mailbox'}.')' : '*') unless @ARGV;
- @LIST_PARAMS = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)');
+ @LIST_PARAMS = ('SUBSCRIBED');
+ push @LIST_PARAMS, map { "$_ (".join(' ', @{$LIST_PARAMS_STATUS{$_}}).")" } keys %LIST_PARAMS_STATUS
+ unless $CONFIG{notify};
}
$LIST .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0])
: ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV;
$IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) };
my $client = $IMAP->{$name}->{client};
- die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED LIST-STATUS UIDPLUS/);
- # XXX We should start by listing all mailboxes matching the user's LIST
- # criterion, then issue "SET NOTIFY (mailboxes ... (...))". But this
- # crashes the IMAP client:
- # http://dovecot.org/pipermail/dovecot/2015-July/101473.html
- #my $mailboxes = $client->list((uc $config{'subscribed-only'} eq 'TRUE' ? '(SUBSCRIBED)' : '' )
- # .$config{mailboxes}, 'SUBSCRIBED');
- # $client->notify('SELECTED', 'MAILBOXES ('.join(' ', keys %$mailboxes).')');
- # XXX NOTIFY doesn't work as expected for INBOX
- # http://dovecot.org/pipermail/dovecot/2015-July/101514.html
- #$client->notify(qw/SELECTED SUBSCRIBED/) if $CONFIG{watch};
- # XXX We shouldn't need to ask for STATUS responses here, and use
- # NOTIFY's STATUS indicator instead. However Dovecot violates RFC
- # 5464: http://dovecot.org/pipermail/dovecot/2015-July/101474.html
+ die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED UIDPLUS/);
+ die "Non LIST-STATUS-capable IMAP server.\n" if !$CONFIG{notify} and $client->incapable('LIST-STATUS');
}
@{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/;
}
-# Wait up to $timout seconds for notifications on either IMAP server.
-# Then issue a NOOP so the connection doesn't terminate for inactivity.
-sub wait_notifications(;$) {
- my $timeout = shift // 300;
-
- while ($timeout > 0) {
- my $r1 = $lIMAP->slurp();
- my $r2 = $rIMAP->slurp();
- last if $r1 or $r2; # got update!
-
- sleep 1;
- if (--$timeout == 0) {
- $lIMAP->noop();
- $rIMAP->noop();
- # might have got updates so exit the loop
- }
- }
-}
-
-
#############################################################################
# Resume interrupted mailbox syncs (before initializing the cache).
#
}
-while(1) {
+if ($CONFIG{notify}) {
+ # Be notified of new messages with EXISTS/RECENT responses, but don't
+ # receive unsolicited FETCH responses with a RFC822/BODY[]. It costs us an
+ # extra roundtrip, but we need to sync FLAG updates and VANISHED responses
+ # in batch mode, update the HIGHESTMODSEQ, and *then* issue an explicit UID
+ # FETCH command to get new message, and process each FETCH response with a
+ # RFC822/BODY[] attribute as they arrive.
+ my $mailboxes = join(' ', map {Net::IMAP::InterIMAP::quote($_)} @MAILBOXES);
+ my %mailboxes = map { $_ => [qw/MessageNew MessageExpunge FlagChange/] }
+ ( "MAILBOXES ($mailboxes)", 'SELECTED' );
+ my %personal = ( personal => [qw/MailboxName SubscriptionChange/] );
+
+ foreach ($lIMAP, $rIMAP) {
+ # require STATUS responses for our @MAILBOXES only
+ $_->notify('SET STATUS', %mailboxes);
+ $_->notify('SET', %mailboxes, %personal);
+ }
+}
+
+
+sub loop() {
while(@MAILBOXES) {
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);
}
}
- # clean state!
- exit 0 unless $CONFIG{watch};
-
- # we need to issue a NOOP command or go back to AUTH state since the
- # LIST command may not report the correct HIGHESTMODSEQ value for
- # the mailbox currently selected.
- if (defined $MAILBOX) {
- # Prefer UNSELECT over NOOP commands as it requires a single command per cycle
- if ($lIMAP->incapable('UNSELECT') or $rIMAP->incapable('UNSELECT')) {
- $_->noop() foreach ($lIMAP, $rIMAP);
- } else {
- $_->unselect() foreach ($lIMAP, $rIMAP);
- undef $MAILBOX;
- }
+}
+sub notify(@) {
+ # TODO: interpret LIST responses to detect mailbox
+ # creation/deletion/subcription/unsubscription
+ # mailbox creation
+ # * LIST () "/" test
+ # mailbox subscribtion
+ # * LIST (\Subscribed) "/" test
+ # mailbox unsubscribtion
+ # * LIST () "/" test
+ # mailbox renaming
+ # * LIST () "/" test2 ("OLDNAME" (test))
+ # mailbox deletion
+ # * LIST (\NonExistent) "/" test2
+ unless (Net::IMAP::InterIMAP::slurp(\@_, $CONFIG{watch}, \&Net::IMAP::InterIMAP::is_dirty)) {
+ $_->noop() foreach @_;
}
+}
+
+unless (defined $CONFIG{watch}) {
+ loop();
+ exit 0;
+}
+
+while (1) {
+ loop();
+
+ if ($CONFIG{notify}) {
+ notify($lIMAP, $rIMAP);
+ }
+ else {
+ # we need to issue a NOOP command or go back to AUTH state since the
+ # LIST command may not report the correct HIGHESTMODSEQ value for
+ # the mailbox currently selected
+ if (defined $MAILBOX) {
+ # Prefer UNSELECT over NOOP commands as it requires a single command per cycle
+ if ($lIMAP->incapable('UNSELECT') or $rIMAP->incapable('UNSELECT')) {
+ $_->noop() foreach ($lIMAP, $rIMAP);
+ } else {
+ $_->unselect() foreach ($lIMAP, $rIMAP);
+ undef $MAILBOX;
+ }
+ }
- sleep $CONFIG{watch};
- # Refresh the mailbox list and status
- @{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/;
- @MAILBOXES = sync_mailbox_list();
+ sleep $CONFIG{watch};
+ # refresh the mailbox list and status
+ @{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/;
+ @MAILBOXES = sync_mailbox_list();
+ }
}
END { cleanup(); }
servers.
Such synchronization is made possible by the [`QRESYNC` IMAP
extension][RFC 7162]; for convenience reasons servers must also support
-the [`LIST-EXTENDED`][RFC 5258], [`LIST-STATUS`][RFC 5819] and
-[`UIDPLUS`][RFC 4315] IMAP extensions.
+the [`LIST-EXTENDED`][RFC 5258], [`LIST-STATUS`][RFC 5819] (or
+[`NOTIFY`][RFC 5465]) and [`UIDPLUS`][RFC 4315] IMAP extensions.
See also the **[supported extensions](#supported-extensions)** section
below.
`--watch`[`=`*seconds*]
: Don't exit after a successful synchronization. Instead, keep
- synchronizing forever. Sleep for the given number of *seconds* (1
- minute by default) between two synchronizations.
- Setting this options enables `SO_KEEPALIVE` on the socket for
- *type*s other than `tunnel`.
+ synchronizing forever. Sleep for the given number of *seconds* (by
+ default 1 minute if `--notify` is unset, and 15 minutes if
+ `--notify` is set) between two synchronizations. Setting this
+ options enables `SO_KEEPALIVE` on the socket for *type*s other than
+ `tunnel`.
+
+`--notify`
+
+: Wether to use the [IMAP `NOTIFY` extension][RFC 5465] to instruct
+ the server to automatically send updates to the client. (Both local
+ and remote servers must support [RFC 5465] for this to work.)
+ This greatly reduces IMAP traffic since `interimap` can rely on
+ server notifications instead of manually polling for updates.
+ If the connection remains idle for 15 minutes (configurable with
+ `--watch`), then `interimap` sends a `NOOP` command to avoid being
+ logged out for inactivity.
`-q`, `--quiet`
* LITERAL+ ([RFC 2088], recommended);
* MULTIAPPEND ([RFC 3502], recommended);
* COMPRESS=DEFLATE ([RFC 4978], recommended);
+ * NOTIFY ([RFC 5465], recommended);
* SASL-IR ([RFC 4959]); and
* UNSELECT ([RFC 3691]).
* B. Leiba and A. Melnikov,
_Internet Message Access Protocol version 4 - LIST Command Extensions_,
[RFC 5258], June 2008.
+ * A. Gulbrandsen, C. King and A. Melnikov,
+ _The IMAP NOTIFY Extension_,
+ [RFC 5465], February 2009
* A. Melnikov and T. Sirainen,
_IMAP4 Extension for Returning STATUS Information in Extended LIST_,
[RFC 5819], March 2010.
[RFC 3691]: https://tools.ietf.org/html/rfc3691
[RFC 6851]: https://tools.ietf.org/html/rfc6851
[RFC 5161]: https://tools.ietf.org/html/rfc5161
+[RFC 5465]: https://tools.ietf.org/html/rfc5465
[INI file]: https://en.wikipedia.org/wiki/INI_file
[PCRE]: https://en.wikipedia.org/wiki/Perl_Compatible_Regular_Expressions
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();
- our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/;
+ our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond
+ slurp is_dirty has_new_mails/;
}
}
-# $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
-# advertise "NOTIFY" (RFC 5465) in its CAPABILITY list.
-sub notify($@) {
+# $self->notify($arg, %specifications)
+# Issue a NOTIFY command with the given $arg ("SET", "SET STATUS" or
+# "NONE") and mailbox %specifications (cf RFC 5465 section 6) to be
+# monitored. Croak if the server did not advertise "NOTIFY" (RFC
+# 5465) in its CAPABILITY list.
+sub notify($$@) {
my $self = shift;
$self->fail("Server did not advertise NOTIFY (RFC 5465) capability.")
unless $self->_capable('NOTIFY');
- my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/;
- # Be notified of new messages with EXISTS/RECENT responses, but
- # don't receive unsolicited FETCH responses with a RFC822/BODY[].
- # It costs us an extra roundtrip, but we need to sync FLAG updates
- # and VANISHED responses in batch mode, update the HIGHESTMODSEQ,
- # and *then* issue an explicit UID FETCH command to get new message,
- # and process each FETCH response with a RFC822/BODY[] attribute as
- # they arrive.
- my $command = 'NOTIFY ';
- $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
+ my $command = 'NOTIFY '.shift;
+ while (@_) {
+ $command .= " (".shift." (".join(' ', @{shift()})."))";
+ }
$self->_send($command);
}
-# $self->slurp([$callback, $cmd, $timeout])
-# See if the server has sent some unprocessed data; try to as many
-# lines as possible, process them, and return the number of lines
-# read.
+# slurp($imap, $timeout, $stopwhen)
+# Keep reading untagged responses from the @$imap servers until the
+# $stopwhen condition becomes true (then return true), or until the
+# $timeout expires (then return false).
# This is mostly useful when waiting for notifications while no
# command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY).
-sub slurp($;&$$) {
- my ($self, $callback, $cmd, $timeout) = @_;
- my $ssl = $self->{_SSL};
- my $read = 0;
+sub slurp($$$) {
+ my ($selfs, $timeout, $stopwhen) = @_;
+ my $aborted = 0;
+
+ my $rin = '';
+ vec($rin, fileno($_->{STDOUT}), 1) = 1 foreach @$selfs;
- vec(my $rin, fileno($self->{STDOUT}), 1) = 1;
while (1) {
- unless ((defined $self->{_OUTBUF} and $self->{_OUTBUF} ne '') or
- # Unprocessed data within the current TLS record would
- # cause select(2) to block/timeout due to the raw socket
- # not being ready.
- (defined $ssl and Net::SSLeay::pending($ssl) > 0)) {
- my $r = CORE::select($rin, undef, undef, $timeout // 0);
+ # first, consider only unprocessed data without our own output
+ # buffer, or within the current TLS record: these would cause
+ # select(2) to block/timeout due to the raw socket not being
+ # ready.
+ my @ready = grep { (defined $_->{_OUTBUF} and $_->{_OUTBUF} ne '') or
+ (defined $_->{_SSL} and Net::SSLeay::pending($_->{_SSL}) > 0)
+ } @$selfs;
+ unless (@ready) {
+ my ($r, $timeleft) = CORE::select(my $rout = $rin, undef, undef, $timeout);
next if $r == -1 and $! == EINTR; # select(2) was interrupted
- $self->panic("Can't select: $!") if $r == -1;
- return $read if $r == 0; # nothing more to read
- $timeout = 0; # don't wait during the next select(2) calls
+ die "select: $!" if $r == -1;
+ return $aborted if $r == 0; # nothing more to read (timeout reached)
+ @ready = grep {vec($rout, fileno($_->{STDOUT}), 1)} @$selfs;
+ $timeout = $timeleft if $timeout > 0;
+ }
+
+ foreach my $imap (@ready) {
+ my $x = $imap->_getline();
+ $imap->_resp($x, sub($) {
+ if ($stopwhen->($imap, shift)) {
+ $aborted = 1;
+ $timeout = 0; # keep reading the handles while there is pending data
+ }
+ }, 'slurp');
}
- my $x = $self->_getline();
- $self->_resp($x, $callback, $cmd);
- $read++;
}
}
-# $self->idle([$timeout, $stopwhen])
+# $self->idle($timeout, $stopwhen)
# Enter IDLE (RFC 2177) for $timout seconds (by default 29 mins), or
# when the callback $stopwhen returns true.
-# Return false if the timeout was reached, and true if IDLE was
-# stopped due the callback.
-sub idle($;$&) {
+# Return true if the callback returned true (either aborting IDLE, or
+# after the $timeout) and false otherwise.
+sub idle($$$) {
my ($self, $timeout, $stopwhen) = @_;
- $timeout //= 1740; # 29 mins
- my $callback = sub() {undef $timeout if $stopwhen->()};
$self->fail("Server did not advertise IDLE (RFC 2177) capability.")
unless $self->_capable('IDLE');
my $tag = $self->_cmd_init('IDLE');
$self->_cmd_flush();
-
- for (my $now = time;;) {
- $self->slurp($callback, 'IDLE', 1);
- last unless defined $timeout;
- my $delta = time - $now;
- $timeout -= $delta;
- # quit idling when a time jump of at least 30s is detected
- last if $timeout <= 0 or $delta >= 30;
- $now += $delta;
- }
+ my $r = slurp([$self], $timeout // 1740, $stopwhen); # 29 mins
# done idling
$self->_cmd_extend('DONE');
$self->_cmd_flush();
# run the callback again to update the return value if we received
# untagged responses between the DONE and the tagged response
- $self->_recv($tag, $callback, 'IDLE');
+ $self->_recv($tag, sub($) { $r = 1 if $stopwhen->($self, shift) }, 'slurp');
- return (defined $timeout) ? 0 : 1;
+ return $r;
}
my $tag = $self->_cmd_init($command);
$self->_cmd_flush();
+ my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command;
if (!defined $callback) {
- $self->_recv($tag);
+ $self->_recv($tag, undef, $cmd);
}
else {
- my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command;
my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
$self->_recv($tag, $callback, $cmd, $set);
}
}
elsif (s/\A(?:OK|NO|BAD) //) {
$self->_resp_text($_);
+ $callback->($self->{_SELECTED}) if defined $self->{_SELECTED} and defined $callback and $cmd eq 'slurp';
}
elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) {
$self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
$self->{_NEW} += $1 - $cache->{EXISTS} if $1 > $cache->{EXISTS}; # new mails
}
$cache->{EXISTS} = $1;
+ $callback->($self->{_SELECTED} // $self->panic()) if defined $callback and $cmd eq 'slurp';
}
elsif (/\A([0-9]+) EXPUNGE\z/) {
$self->panic() unless defined $cache->{EXISTS}; # sanity check
/\A \((\\?$RE_ATOM_CHAR+ [0-9]+(?: \\?$RE_ATOM_CHAR+ [0-9]+)*)?\)\z/ or $self->panic($_);
my %status = split / /, $1;
$mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
+ $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response")
+ if $self->_enabled('QRESYNC') and !defined $status{HIGHESTMODSEQ} and defined $cmd and
+ ($cmd eq 'NOTIFY' or $cmd eq 'slurp');
$self->_update_cache_for($mailbox, %status);
- $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS';
+ if (defined $callback) {
+ if ($cmd eq 'STATUS') {
+ $callback->($mailbox, %status);
+ } elsif ($cmd eq 'slurp') {
+ $callback->($mailbox);
+ }
+ }
}
elsif (s/\A([0-9]+) FETCH \(//) {
$cache->{EXISTS} = $1 if $1 > $cache->{EXISTS};
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
- defined $uid and in_set($uid, $set);
+ if (defined $callback) {
+ if ($cmd eq 'FETCH' or $cmd eq 'STORE') {
+ $callback->(\%mail) if defined $uid and in_set($uid, $set);
+ } elsif ($cmd eq 'slurp') {
+ $callback->($self->{_SELECTED} // $self->panic())
+ }
+ }
}
elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE
$self->{_ENABLED} //= [];
push @{$self->{_VANISHED}}, ($min .. $max);
}
}
+ $callback->($self->{_SELECTED} // $self->panic()) if defined $callback and $cmd eq 'slurp';
}
}
elsif (s/\A\+// and ($_ eq '' or s/\A //)) {
else {
$self->panic("Unexpected response: ", $_);
}
- $callback->() if defined $callback and $cmd eq 'IDLE';
}
$CONFIG{idle} = 1740 if defined $CONFIG{idle} and $CONFIG{idle} == 0; # 29 mins
while(1) {
- my $r = $IMAP->idle($CONFIG{idle}, sub() { $IMAP->has_new_mails($MAILBOX) });
- pull() if $r;
+ pull() if $IMAP->idle($CONFIG{idle}, \&Net::IMAP::InterIMAP::has_new_mails);
purge();
}
projects / interimap.git / commitdiff