diff options
author | Guilhem Moulin <guilhem@fripost.org> | 2016-03-12 22:14:39 +0100 |
---|---|---|
committer | Guilhem Moulin <guilhem@fripost.org> | 2016-03-12 22:40:58 +0100 |
commit | 85fd56f6f150dba0d74859a9d5e00f16d6b33955 (patch) | |
tree | f8a57fe4f81acfc8ad4a3f6a18d9c44be2267d4d | |
parent | c8376a4c8130f98a56fd65e370032c27234ed323 (diff) |
Net::IMAP::InterIMAP, interimap: Add support for IMAP NOTIFY [RFC 5465].
Unsollicited LIST responses are currently ignored, hence interimap won't
detect mailbox creation/deletion/subcription/unsubscription.
-rwxr-xr-x | interimap | 134 | ||||
-rw-r--r-- | interimap.md | 29 | ||||
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 135 | ||||
-rwxr-xr-x | pullimap | 3 |
4 files changed, 175 insertions, 126 deletions
@@ -54,7 +54,7 @@ sub usage(;$) { } 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; @@ -62,9 +62,9 @@ my $COMMAND = do { $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; @@ -237,10 +237,13 @@ logger(undef, ">>> $NAME $VERSION"); 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; @@ -258,20 +261,8 @@ foreach my $name (qw/local remote/) { $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/; @@ -1067,26 +1058,6 @@ sub sync_messages($$;$$) { } -# 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). # @@ -1167,7 +1138,27 @@ if (defined $COMMAND and $COMMAND eq 'repair') { } -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 @@ -1203,26 +1194,55 @@ while(1) { 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(); } diff --git a/interimap.md b/interimap.md index 2d783a8..0632363 100644 --- a/interimap.md +++ b/interimap.md @@ -19,8 +19,8 @@ Description 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. @@ -152,10 +152,22 @@ Options `--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` @@ -369,6 +381,7 @@ the [IMAP4rev1 protocol][RFC 3501]: * 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]). @@ -440,6 +453,9 @@ Standards * 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. @@ -468,6 +484,7 @@ Standards [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 diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index d2bb130..a899831 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -35,7 +35,8 @@ BEGIN { 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/; } @@ -909,93 +910,89 @@ 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 -# 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; } @@ -1920,11 +1917,11 @@ sub _send($$;&) { 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); } @@ -2232,6 +2229,7 @@ sub _resp($$;&$$) { } 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) ]; @@ -2249,6 +2247,7 @@ sub _resp($$;&$$) { $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 @@ -2281,8 +2280,17 @@ sub _resp($$;&$$) { /\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}; @@ -2328,8 +2336,13 @@ 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 - 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} //= []; @@ -2353,6 +2366,7 @@ sub _resp($$;&$$) { 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 //)) { @@ -2366,7 +2380,6 @@ sub _resp($$;&$$) { else { $self->panic("Unexpected response: ", $_); } - $callback->() if defined $callback and $cmd eq 'IDLE'; } @@ -346,7 +346,6 @@ unless (defined $CONFIG{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(); } |