From: Guilhem Moulin Date: Mon, 7 Sep 2015 15:36:00 +0000 (+0200) Subject: Rename ‘imapsync’ to ‘interimap’. X-Git-Url: https://git.g-eek.se/?a=commitdiff_plain;h=ac3e4cf6300448e9c83b45db1b769d79c6df2e38;p=interimap.git Rename ‘imapsync’ to ‘interimap’. To avoid confusion with http://imapsync.lamiral.info . --- diff --git a/Changelog b/Changelog index 4c3a493..acd02d2 100644 --- a/Changelog +++ b/Changelog @@ -1,5 +1,5 @@ -imapsync (0.1) upstream; +interimap (0.1) upstream; - * Initial release. + * Initial public release. Development was started in July 2015. - -- Guilhem Moulin Thu, 23 Jul 2015 04:15:47 +0200 + -- Guilhem Moulin Mon, 07 Sep 2015 17:14:42 +0200 diff --git a/INSTALL b/INSTALL index 7cfbdc3..e11e08a 100644 --- a/INSTALL +++ b/INSTALL @@ -1,4 +1,4 @@ -imapsync depends on the following Perl modules: +InterIMAP depends on the following Perl modules: - Config::Tiny - DBI diff --git a/README b/README index 1195720..44190f3 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ -imapsync is a fast bidirectional synchronization program for -QRESYNC-capable IMAP servers. Consult the manual for more information. +InterIMAP is a fast two-way synchronization program for QRESYNC-capable +IMAP4rev1 servers. Consult the manual for more information. ####################################################################### @@ -17,14 +17,14 @@ propagate changes (flag updates and message deletions) to existing messages, then 2/ copy the new messages. The naive way to perform the first step is to issue a FETCH command to list all messages in the mailbox along with their flags and UIDs, causing heavy network usage. -Instead, imapsync takes advantage of the QRESYNC extension from +Instead, InterIMAP takes advantage of the QRESYNC extension from [RFC7162] to perform stateful synchronization: querying changes since the last synchronization only gives a phenomenal performance boost and drastically reduces the network traffic. For convenience reasons servers must also support LIST-EXTENDED [RFC5258], LIST-STATUS [RFC5819] and UIDPLUS [RFC4315]. Furthermore, -while imapsync can work with servers lacking support for LITERAL+ +while InterIMAP can work with servers lacking support for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions greatly improve performance by reducing the number of required round trips hence are recommended. @@ -50,14 +50,14 @@ the AUTHENTICATE command. For instance the following configuration snippet saves bandwidth and brings a significant speed gain compared to type=imaps. - local: $XDG_CONFIG_HOME/imapsync: + local: $XDG_CONFIG_HOME/interimap: [remote] type = tunnel command = /usr/bin/ssh user@imap.example.net local: ~/.ssh/config: Host imap.example.net - IdentityFile ~/.ssh/id-imapsync + IdentityFile ~/.ssh/id-interimap IdentitiesOnly yes ControlPath /run/shm/%u@%n ControlMaster auto @@ -69,12 +69,12 @@ type=imaps. Compression yes remote: ~user/.ssh/authorized_keys: - command="/usr/lib/dovecot/imap",no-agent-forwarding,no-port-forwarding,no-pty,no-user-rc,no-X11-forwarding ssh-... id-imapsync + command="/usr/lib/dovecot/imap",no-agent-forwarding,no-port-forwarding,no-pty,no-user-rc,no-X11-forwarding ssh-... id-interimap ####################################################################### -imapsync is Copyright© 2015 Guilhem Moulin ⟨guilhem@fripost.org⟩, and +InterIMAP is Copyright© 2015 Guilhem Moulin ⟨guilhem@fripost.org⟩, and licensed for use under the GNU General Public License version 3 or later. See ‘COPYING’ for specific terms and distribution information. diff --git a/imapsync b/imapsync deleted file mode 100755 index a454c5d..0000000 --- a/imapsync +++ /dev/null @@ -1,1197 +0,0 @@ -#!/usr/bin/perl -T - -#---------------------------------------------------------------------- -# IMAP-to-IMAP synchronization program for QRESYNC-capable servers -# Copyright © 2015 Guilhem Moulin -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#---------------------------------------------------------------------- - -use strict; -use warnings; - -our $VERSION = '0.1'; -my $NAME = 'imapsync'; -use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat - bundling auto_version/; -use DBI (); -use List::Util 'first'; - -use lib 'lib'; -use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/; - -# Clean up PATH -$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin}; -delete @ENV{qw/IFS CDPATH ENV BASH_ENV/}; - -my %CONFIG; -sub usage(;$) { - my $rv = shift // 0; - if ($rv) { - print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n" - ."Try '$NAME --help' or consult the manpage for more information.\n"; - } - else { - print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n" - ." or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n" - ." or: $NAME [OPTIONS] --delete MAILBOX [..]\n" - ." or: $NAME [OPTIONS] --rename SOURCE DEST\n" - ."Consult the manpage for more information.\n"; - } - exit $rv; -} -usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h repair delete rename/); -usage(0) if $CONFIG{help}; -my $COMMAND = do { - my @command = grep {exists $CONFIG{$_}} qw/repair delete rename/; - usage(1) if $#command>0; - $command[0] -}; -usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND eq 'rename' and $#ARGV != 1); -@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive - - -my $CONF = read_config( delete $CONFIG{config} // $NAME - , [qw/_ local remote/] - , database => qr/\A(\P{Control}+)\z/ - , logfile => qr/\A(\/\P{Control}+)\z/ - , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ - , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/ - , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ - ); -my ($DBFILE, $LOCKFILE, $LOGGER_FD); - -{ - $DBFILE = $CONF->{_}->{database} if defined $CONF->{_}; - $DBFILE //= $CONF->{remote}->{host}.'.db' if defined $CONF->{remote}; - $DBFILE //= $CONF->{local}->{host}. '.db' if defined $CONF->{local}; - die "Missing option database" unless defined $DBFILE; - - unless ($DBFILE =~ /\A\//) { - my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME; - $dir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $dir"; - $dir = $1; - $DBFILE = $dir .'/'. $DBFILE; - unless (-d $dir) { - mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n"; - } - } - - $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r; - - if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) { - require 'POSIX.pm'; - require 'Time/HiRes.pm'; - open $LOGGER_FD, '>>', $CONF->{_}->{logfile} - or die "Can't open $CONF->{_}->{logfile}: $!\n"; - $LOGGER_FD->autoflush(1); - } - elsif ($CONFIG{debug}) { - $LOGGER_FD = \*STDERR; - } -} -my $DBH; - -# Clean after us -sub cleanup() { - logger(undef, "Cleaning up...") if $CONFIG{debug}; - unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE; - close $LOGGER_FD if defined $LOGGER_FD; - $DBH->disconnect() if defined $DBH; -} -$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 1; } foreach qw/INT TERM/; -$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 0; } foreach qw/HUP/; - - -############################################################################# -# Lock the database -{ - if (-f $LOCKFILE) { - open my $lock, '<', $LOCKFILE or die "Can't open $LOCKFILE: $!\n"; - my $pid = <$lock>; - close $lock; - chomp $pid; - my $msg = "LOCKFILE '$LOCKFILE' exists."; - $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/; - die $msg, "\n"; - } - - open my $lock, '>', $LOCKFILE or die "Can't open $LOCKFILE: $!\n"; - print $lock $$, "\n"; - close $lock; -} - - -############################################################################# -# Open the database and create tables - -$DBH = DBI::->connect("dbi:SQLite:dbname=$DBFILE", undef, undef, { - AutoCommit => 0, - RaiseError => 1, - sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not -}); -$DBH->do('PRAGMA foreign_keys = ON'); - - -{ - my @schema = ( - mailboxes => [ - q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT}, - q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE}, - q{subscribed BOOLEAN NOT NULL} - ], - 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}, # 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}, # 0 initially - q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially - # one-to-one correspondence between local.idx and remote.idx - ], - mapping => [ - q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)}, - q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)}, - 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 (except for interrupted syncs) - # mapping.idx must be found among local.idx (and remote.idx) - ], - ); - - # Invariants: - # * UIDVALIDITY never changes. - # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ < - # {local,remote}.HIGHESTMODSEQ have been propagated. - # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT - # (resp. <= remote.UIDNEXT). - # * Any idx in `local` must be present in `remote` and vice-versa. - # * Any idx in `mapping` must be present in `local` and `remote`. - while (@schema) { - my $table = shift @schema; - my $schema = shift @schema; - my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1}); - my $row = $sth->fetch(); - die if defined $sth->fetch(); # sanity check - unless (defined $row) { - $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")"); - $DBH->commit(); - } - } -} - -sub msg($@) { - my $name = shift; - return unless @_; - logger($name, @_) if defined $LOGGER_FD and $LOGGER_FD->fileno != fileno STDERR; - my $prefix = defined $name ? "$name: " : ''; - print STDERR $prefix, @_, "\n"; -} -sub logger($@) { - my $name = shift; - return unless @_ and defined $LOGGER_FD; - my $prefix = ''; - if ($LOGGER_FD->fileno != fileno STDERR) { - my ($s, $us) = Time::HiRes::gettimeofday(); - $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; - } - $prefix .= "$name: " if defined $name; - $LOGGER_FD->say($prefix, @_); -} -logger(undef, ">>> $NAME $VERSION"); - - -############################################################################# -# Connect to the local and remote IMAP servers - -my $IMAP; -foreach my $name (qw/local remote/) { - my %config = %{$CONF->{$name}}; - $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/; - $config{enable} = 'QRESYNC'; - $config{name} = $name; - $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD; - - $IMAP->{$name} = { client => Net::IMAP::Sync::->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 - - my $list = '"" '; - my @params; - 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; - @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)'); - } - $list .= $#ARGV == 0 ? Net::IMAP::Sync::quote($ARGV[0]) - : ('('.join(' ',map {Net::IMAP::Sync::quote($_)} @ARGV).')') if @ARGV; - @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list($list, @params); -} - - -############################################################################## -# - -# Add a new mailbox to the database. -my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); - -# Get the index associated with a mailbox. -my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?}); - -# Ensure local and remote delimiter match -sub check_delim($) { - my $mbx = shift; - my ($lDelims, $rDelims) = map {$IMAP->{$_}->{delims}} qw/local remote/; - if (exists $lDelims->{$mbx} and exists $rDelims->{$mbx} and - ((defined $lDelims->{$mbx} xor defined $rDelims->{$mbx}) or - (defined $lDelims->{$mbx} and defined $rDelims->{$mbx} and $lDelims->{$mbx} ne $rDelims->{$mbx}))) { - my ($ld, $rd) = ($lDelims->{$mbx}, $rDelims->{$mbx}); - $ld =~ s/([\x22\x5C])/\\$1/g if defined $ld; - $rd =~ s/([\x22\x5C])/\\$1/g if defined $rd; - die "Error: Hierarchy delimiter for $mbx don't match: " - ."local \"". ($ld // '')."\", remote \"".($rd // '')."\"\n" - } - return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef; -} - -# Return true if $mailbox exists on $name -sub mbx_exists($$) { - my ($name, $mailbox) = @_; - my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; - return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0; -} - -# Return true if $mailbox is subscribed to on $name -sub mbx_subscribed($$) { - my ($name, $mailbox) = @_; - my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; - return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0; -} - - -############################################################################## -# Process --delete command -# -if (defined $COMMAND and $COMMAND eq 'delete') { - my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?}); - my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?}); - my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?}); - my $sth_delete_mapping = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ?}); - - foreach my $mailbox (@ARGV) { - $STH_GET_INDEX->execute($mailbox); - my ($idx) = $STH_GET_INDEX->fetchrow_array(); - die if defined $STH_GET_INDEX->fetch(); # sanity check - - # delete $mailbox on servers where $mailbox exists. note that - # there is a race condition where the mailbox could have - # appeared meanwhile - foreach my $name (qw/local remote/) { - next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; - $IMAP->{$name}->{client}->delete($mailbox) if mbx_exists($name, $mailbox); - } - - if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { - my $r1 = $sth_delete_mapping->execute($idx); - msg('database', "WARNING: `DELETE FROM mapping WHERE idx = $idx` failed") unless $r1; - my $r2 = $sth_delete_local->execute($idx); - msg('database', "WARNING: `DELETE FROM local WHERE idx = $idx` failed") unless $r2; - my $r3 = $sth_delete_remote->execute($idx); - msg('database', "WARNING: `DELETE FROM remote WHERE idx = $idx` failed") unless $r3; - my $r4 = $sth_delete_mailboxes->execute($idx); - msg('database', "WARNING: `DELETE FROM mailboxes WHERE idx = $idx` failed") unless $r4; - - $DBH->commit(); - msg('database', "Removed mailbox $mailbox") if $r4; - } - } - exit 0; -} - - -############################################################################## -# Process --rename command -# -elsif (defined $COMMAND and $COMMAND eq 'rename') { - my ($from, $to) = @ARGV; - - # get index of the original name - $STH_GET_INDEX->execute($from); - my ($idx) = $STH_GET_INDEX->fetchrow_array(); - die if defined $STH_GET_INDEX->fetch(); # sanity check - - # ensure the local and remote hierarchy delimiter match - my $delim = check_delim($from); - - # ensure the target name doesn't already exist on the servers. there - # is a race condition where the mailbox would be created before we - # issue the RENAME command, then the server would reply with a - # tagged NO response - foreach my $name (qw/local remote/) { - next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; - if (mbx_exists($name, $to)) { - msg($name, "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); - exit 1; - } - } - - # ensure the target name doesn't already exist in the database - $STH_GET_INDEX->execute($to); - if (defined $STH_GET_INDEX->fetch() and - (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { - msg('database', "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); - exit 1; - } - - - # rename $from to $to on servers where $from exists. again there is - # a race condition, but if $to has been created meanwhile the server - # will reply with a tagged NO response - foreach my $name (qw/local remote/) { - next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; - $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from); - } - - # rename from to $to in the database - if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { - my $sth_rename_mailbox = $DBH->prepare(q{UPDATE mailboxes SET mailbox = ? WHERE idx = ?}); - my $r = $sth_rename_mailbox->execute($to, $idx); - msg('database', "WARNING: `UPDATE mailboxes SET mailbox = ".$DBH->quote($to)." WHERE idx = $idx` failed") unless $r; - - # for non-flat mailboxes, rename the children as well - if (defined $delim) { - my $prefix = $from.$delim; - my $sth_rename_children = $DBH->prepare(q{ - UPDATE mailboxes SET mailbox = ? || SUBSTR(mailbox,?) - WHERE SUBSTR(mailbox,1,?) = ? - }); - $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix); - } - - $DBH->commit(); - msg('database', "Renamed mailbox $from to $to") if $r; - } - exit 0; -} - - -############################################################################## -# Synchronize mailbox and subscription lists - -my @MAILBOXES; -{ - my %mailboxes; - $mailboxes{$_} = 1 foreach keys %{$IMAP->{local}->{mailboxes}}; - $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}}; - my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); - - foreach my $mailbox (keys %mailboxes) { - next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox =~ /$CONF->{_}->{'ignore-mailbox'}/o; - my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; - next unless $lExists or $rExists; - - my @attrs = do { - my %attrs = map {$_ => 1} (@{$IMAP->{local}->{mailboxes}->{$mailbox} // []}, - @{$IMAP->{remote}->{mailboxes}->{$mailbox} // []}); - keys %attrs; - }; - - check_delim($mailbox); # ensure that the delimiter match - push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs; - - $STH_GET_INDEX->execute($mailbox); - my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); - die if defined $STH_GET_INDEX->fetch(); # sanity check - - if ($lExists and $rExists) { - # $mailbox exists on both sides - my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/; - if (defined $idx) { - if ($lSubscribed xor $rSubscribed) { - # mailbox is subscribed on only one server - if ($subscribed) { # unsubscribe - my $name = $lSubscribed ? 'local' : 'remote'; - $IMAP->{$name}->{client}->unsubscribe($mailbox); - } - else { # subscribe - my $name = $lSubscribed ? 'remote' : 'local'; - $IMAP->{$name}->{client}->subscribe($mailbox); - } - # toggle subscribtion in the database - $subscribed = $subscribed ? 0 : 1; - $sth_subscribe->execute($subscribed, $idx) or - msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $subscribed WHERE idx = $idx` failed"); - $DBH->commit(); - } - # $mailbox is either subscribed on both servers, or subscribed on both - elsif ($lSubscribed xor $subscribed) { - # update the database if needed - $sth_subscribe->execute($lSubscribed, $idx) or - msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $lSubscribed WHERE idx = $idx` failed"); - $DBH->commit(); - } - } - else { - # add new mailbox; subscribe on both servers if $mailbox is subscribed on one of them - my $subscribed = ($lSubscribed or $rSubscribed) ? 1 : 0; - $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed and !$lSubscribed; - $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed and !$rSubscribed; - $DBH->commit(); - } - } - elsif ($lExists and !$rExists) { - # $mailbox is on 'local' only - if (defined $idx) { - msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); - exit 1; - } - my $subscribed = mbx_subscribed('local', $mailbox); - $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{remote}->{client}->create($mailbox, 1); - $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed; - $DBH->commit(); - } - elsif (!$lExists and $rExists) { - # $mailbox is on 'remote' only - if (defined $idx) { - msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); - exit 1; - } - my $subscribed = mbx_subscribed('remote', $mailbox); - $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{local}->{client}->create($mailbox, 1); - $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed; - $DBH->commit(); - } - } -} -my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/; -undef $IMAP; - - -############################################################################# -# Synchronize messages - -# Get all cached states from the database. -my $STH_GET_CACHE = $DBH->prepare(q{ - SELECT mailbox, m.idx AS idx, - l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ, - r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ - FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx -}); -my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{ - SELECT mailbox, - l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ, - r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ - FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx - WHERE m.idx = ? -}); - -# Find local/remote UID from the map. -my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?}); -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! -my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?}); - -# Update the HIGHESTMODSEQ. -my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?}); -my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?}); - -# Update the HIGHESTMODSEQ and UIDNEXT. -my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); -my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); - -# Add a new mailbox. -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) -}); - -# Count messages -my $STH_COUNT_MESSAGES = $DBH->prepare(q{SELECT COUNT(*) FROM mapping WHERE idx = ?}); - -# List last 1024 messages UIDs -my $STH_LASTUIDs_LOCAL = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? ORDER BY lUID DESC LIMIT 1024}); -my $STH_LASTUIDs_REMOTE = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? ORDER BY rUID DESC LIMIT 1024}); - - -# Download some missing UIDs from $source; returns the thew allocated UIDs -sub download_missing($$$@) { - my $idx = shift; - my $mailbox = shift; - my $source = shift; - my @set = @_; - my @uids; - - my $target = $source eq 'local' ? 'remote' : 'local'; - - 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 eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) { - my $mail = shift; - return unless exists $mail->{RFC822}; # not for us - - 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] : ''; - msg(undef, "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet}; - - 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); - msg(undef, "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ". - "and remote UID $rUID ($rFlags). Setting both to the union ($flags)."); - - return $flags -} - - -# 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 - msg('database', "WARNING: Can't delete (idx,lUID) = ($idx,$lUID)") if $r == 0; -} - - -# Create a sample (sequence numbers, UIDs) to use as Message Sequence -# Match Data for the QRESYNC parameter to the SELECT command. -# QRESYNC [RFC7162] doesn't force the server to remember the MODSEQs of -# EXPUNGEd messages. By passing a sample of known sequence numbers/UIDs -# we let the server know that the messages have been EXPUNGEd [RFC7162, -# section 3.2.5.2]. -# The UID set is the largest set of higest UIDs with at most 1024 UIDs, -# of length (after compacting) at most 64. -# The reason why we sample with the highest UIDs is that lowest UIDs are -# less likely to be deleted. -sub sample($$$) { - my ($idx, $count, $sth) = @_; - return unless $count > 0; - - my ($n, $uids, $min, $max); - $sth->execute($idx); - while (defined (my $row = $sth->fetchrow_arrayref())) { - my $k = $row->[0]; - if (!defined $min and !defined $max) { - $n = 0; - $min = $max = $k; - } - elsif ($k == $min - 1) { - $min--; - } - else { - $n += $max - $min + 1; - $uids = ($min == $max ? $min : "$min:$max") - .(defined $uids ? ','.$uids : ''); - $min = $max = $k; - if (length($uids) > 64) { - $sth->finish(); # done with the statement - last; - } - } - } - if (!defined $uids or length($uids) <= 64) { - $n += $max - $min + 1; - $uids = ($min == $max ? $min : "$min:$max") - .(defined $uids ? ','.$uids : ''); - } - return ( ($count - $n + 1).':'.$count, $uids ); -} - - -# Issue a SELECT command with the given $mailbox. -sub select_mbx($$) { - my ($idx, $mailbox) = @_; - - $STH_COUNT_MESSAGES->execute($idx); - my ($count) = $STH_COUNT_MESSAGES->fetchrow_array(); - die if defined $STH_COUNT_MESSAGES->fetch(); # sanity check - - $lIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_LOCAL)); - $rIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_REMOTE)); -} - - -# Check and repair synchronization of a mailbox between the two servers -# (in a very crude way, by downloading all existing UID with their flags) -sub repair($) { - my $mailbox = shift; - - $STH_GET_INDEX->execute($mailbox); - my ($idx) = $STH_GET_INDEX->fetchrow_array(); - die if defined $STH_GET_INDEX->fetch(); # sanity check - - return unless defined $idx; # not in the database - select_mbx($idx, $mailbox); - - $STH_GET_CACHE_BY_IDX->execute($idx); - my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // return; # no cache - die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check - - # 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; - - # 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); - while (defined (my $row = $STH_GET_MAPPING->fetch())) { - my ($lUID, $rUID) = @$row; - 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 { - # conflict - msg(undef, "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.") - 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 $lModified->{$lUID} and !defined $rModified->{$rUID}) { - unless ($lVanished{$lUID} and $rVanished{$rUID}) { - msg(undef, "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing."); - push @delete_mapping, $lUID; - } - } - elsif (!defined $lModified->{$lUID}) { - push @delete_mapping, $lUID; - if ($lVanished{$lUID}) { - push @rToRemove, $rUID; - } else { - msg("local($mailbox)", "WARNING: UID $lUID disappeared. Downloading remote UID $rUID again."); - push @rMissing, $rUID; - } - } - elsif (!defined $rModified->{$rUID}) { - push @delete_mapping, $lUID; - if ($rVanished{$rUID}) { - push @lToRemove, $lUID; - } else { - msg("remote($mailbox)", "WARNING: UID $rUID disappeared. Downloading local UID $lUID again."); - push @lMissing, $lUID; - } - } - - delete $lModified->{$lUID}; - delete $lVanished{$lUID}; - delete $rModified->{$rUID}; - delete $rVanished{$rUID}; - } - - # 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; - - # 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. - my @lDunno = keys %lVanished; - my @rDunno = keys %rVanished; - msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " - .compact_set(@lDunno).". Ignoring.") if @lDunno; - msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " - .compact_set(@rDunno).". Ignoring.") if @rDunno; - - foreach my $lUID (keys %$lModified) { - msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Downloading again."); - push @lMissing, $lUID; - } - foreach my $rUID (keys %$rModified) { - msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Downloading again."); - 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); -} - - -# Sync known messages. Since pull_updates is the last method call on -# $lIMAP and $rIMAP, it is safe to call get_cache on either object after -# this function, in order to update the HIGHESTMODSEQ. -# Return true if an update was detected, and false otherwise -sub sync_known_messages($$) { - my ($idx, $mailbox) = @_; - my $update = 0; - - # loop since processing might produce VANISHED or unsollicited FETCH responses - while (1) { - my ($lVanished, $lModified, $rVanished, $rModified); - - ($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; - $update = 1; - - # process VANISHED messages - # /!\ this might modify the VANISHED or MODIFIED cache! - if (@$lVanished or @$rVanished) { - my %lVanished = map {$_ => 1} @$lVanished; - my %rVanished = map {$_ => 1} @$rVanished; - - # For each vanished UID, get the corresponding one on the - # other side (from the DB); consider it as to be removed if - # it hasn't been removed already. - - my (@lToRemove, @rToRemove, @lDunno, @rDunno); - foreach my $lUID (@$lVanished) { - $STH_GET_REMOTE_UID->execute($idx, $lUID); - my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); - die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check - if (!defined $rUID) { - push @lDunno, $lUID; - } - elsif (!exists $rVanished{$rUID}) { - push @rToRemove, $rUID; - } - } - foreach my $rUID (@$rVanished) { - $STH_GET_LOCAL_UID->execute($idx, $rUID); - my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); - die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check - if (!defined $lUID) { - push @rDunno, $rUID; - } - elsif (!exists $lVanished{$lUID}) { - push @lToRemove, $lUID; - } - } - - msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " - .compact_set(@lDunno).". Ignoring.") if @lDunno; - msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " - .compact_set(@rDunno).". Ignoring.") if @rDunno; - - $lIMAP->remove_message(@lToRemove) if @lToRemove; - $rIMAP->remove_message(@rToRemove) if @rToRemove; - - # remove existing mappings - foreach my $lUID (@$lVanished, @lToRemove) { - delete_mapping($idx, $lUID); - } - } - - # process FLAG updates - # /!\ this might modify the VANISHED or MODIFIED cache! - if (%$lModified or %$rModified) { - my (%lToUpdate, %rToUpdate); - - # Take flags updates on both sides, and get the - # corresponding UIDs on the other side (from the DB). - # If it wasn't modified there, make it such; if it was - # modified with the same flags list, ignore that message; - # otherwise there is a conflict, and take the union. - # - # Group by flags in order to limit the number of round - # trips. - - while (my ($lUID,$lFlags) = each %$lModified) { - $STH_GET_REMOTE_UID->execute($idx, $lUID); - my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); - die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check - if (!defined $rUID) { - msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Try '--repair'."); - } - elsif (defined (my $rFlags = $rModified->{$rUID})) { - unless ($lFlags eq $rFlags) { - my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags); - $lToUpdate{$flags} //= []; - push @{$lToUpdate{$flags}}, $lUID; - $rToUpdate{$flags} //= []; - push @{$rToUpdate{$flags}}, $rUID; - } - } - else { - $rToUpdate{$lFlags} //= []; - push @{$rToUpdate{$lFlags}}, $rUID; - } - } - while (my ($rUID,$rFlags) = each %$rModified) { - $STH_GET_LOCAL_UID->execute($idx, $rUID); - my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); - die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check - if (!defined $lUID) { - msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Try '--repair'."); - } - elsif (!exists $lModified->{$lUID}) { - # conflicts are taken care of above - $lToUpdate{$rFlags} //= []; - push @{$lToUpdate{$rFlags}}, $lUID; - } - } - - while (my ($lFlags,$lUIDs) = each %lToUpdate) { - $lIMAP->push_flag_updates($lFlags, @$lUIDs); - } - while (my ($rFlags,$rUIDs) = each %rToUpdate) { - $rIMAP->push_flag_updates($rFlags, @$rUIDs); - } - } - } -} - - -# 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) { - msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})"); - return; - } - - 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; -} - - -# 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) = @_; - - 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 - - my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID); - for (my $k=0; $k<=$#messages; $k++) { - logger(undef, "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox") - if $CONFIG{debug}; - $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]); - } - $DBH->commit(); # commit only once per batch - - return @tUID; -} - - -# 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 %ignore = (local => ($lIgnore // []), remote => ($rIgnore // [])); - my $loop; - do { - # get new messages from $source (except @{$ignore{$source}}) and APPEND them to $target - foreach my $source (qw/remote local/) { # pull remote mails first - my $target = $source eq 'remote' ? 'local' : 'remote'; - my $buff = [] unless ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND'); - my $bufflen = 0; - my @tUIDs; - - ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages(sub($) { - callback_new_message($idx, $mailbox, $source, shift, \@tUIDs, $buff, \$bufflen) - }, @{$ignore{$source}}); - - push @tUIDs, callback_new_message_flush($idx, $mailbox, $source, @$buff) - if defined $buff and @$buff; - push @{$ignore{$target}}, @tUIDs; - - $loop = @tUIDs ? 1 : 0; - } - # since $source modifies $target's UIDNEXT upon new mails, we - # need to check again the first $source (remote) whenever the - # last one (local) added new messages to it - } - while ($loop); - - # 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) or - msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox"); - $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $idx) or - msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox"); - $DBH->commit(); -} - - -# 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). -# -my ($MAILBOX, $IDX); -$STH_LIST_INTERRUPTED->execute(); -while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { - next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailbox - ($IDX, $MAILBOX) = @$row; - msg(undef, "Resuming interrupted sync for $MAILBOX"); - - 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. -# -my %KNOWN_INDEXES; -$STH_GET_CACHE->execute(); -while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { - next unless grep {$row->{mailbox} eq $_} @MAILBOXES; - $lIMAP->set_cache($row->{mailbox}, - UIDVALIDITY => $row->{lUIDVALIDITY}, - UIDNEXT => $row->{lUIDNEXT}, - HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ} - ); - $rIMAP->set_cache($row->{mailbox}, - UIDVALIDITY => $row->{rUIDVALIDITY}, - UIDNEXT => $row->{rUIDNEXT}, - HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ} - ); - $KNOWN_INDEXES{$row->{idx}} = 1; -} - -if (defined $COMMAND and $COMMAND eq 'repair') { - repair($_) foreach @MAILBOXES; - exit 0; -} - - -while(1) { - while(@MAILBOXES) { - 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); - } - else { - $MAILBOX = $lIMAP->next_dirty_mailbox(@MAILBOXES) // $rIMAP->next_dirty_mailbox(@MAILBOXES) // last; - $MAILBOX = 'INBOX' if uc $MAILBOX eq 'INBOX'; # INBOX is case insensitive - - $STH_GET_INDEX->execute($MAILBOX); - ($IDX) = $STH_GET_INDEX->fetchrow_array(); - die if defined $STH_GET_INDEX->fetch(); # sanity check - die unless defined $IDX; # sanity check; - - select_mbx($IDX, $MAILBOX); - - if (!$KNOWN_INDEXES{$IDX}) { - $STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX)); - $STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX)); - - # no need to commit before the first mapping (lUID,rUID) - $KNOWN_INDEXES{$IDX} = 1; - } - 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) or - msg('database', "WARNING: Can't update local HIGHESTMODSEQ for $MAILBOX"); - $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or - msg('database', "WARNING: Can't update remote HIGHESTMODSEQ for $MAILBOX"); - $DBH->commit(); - } - sync_messages($IDX, $MAILBOX); - } - } - # clean state! - exit 0 unless defined $COMMAND and $COMMAND eq 'watch'; - wait_notifications(900); -} - -END { - $_->logout() foreach grep defined, ($lIMAP, $rIMAP); - cleanup(); -} diff --git a/imapsync.1 b/imapsync.1 deleted file mode 100644 index af753b3..0000000 --- a/imapsync.1 +++ /dev/null @@ -1,333 +0,0 @@ -.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 ...] [\fICOMMAND\fR] [\fIMAILBOX\fR ...] - - -.SH DESCRIPTION -.PP -.B imapsync\fR performs stateful synchronization between two IMAP4rev1 -servers. -Such synchronization is made possible by the QRESYNC extension from -[RFC7162]; for convenience reasons servers must also support -LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315]. -Furthermore, while \fBimapsync\fR can work with servers lacking support -for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions -greatly improve performance by reducing the number of required round -trips hence are recommended. - -.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] 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 value 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 value 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. - -.SH COMMANDS -.PP -By default \fBimapsync\fR synchronizes each mailbox listed by the -\(lqLIST "" "*"\(rq IMAP command; -the \fIlist-mailbox\fR, \fIlist-select-opts\fR and \fIignore-mailbox\fR -options from the configuration file can be used to shrink that list and -save bandwidth. -However if some extra argument are provided on the command line, -\fBimapsync\fR ignores said options and synchronizes the given -\fIMAILBOX\fRes instead. Note that each \fIMAILBOX\fR is taken \(lqas -is\(rq; in particular, it must be UTF-7 encoded, unquoted, and the list -wildcards \(oq*\(cq and \(oq%\(cq are not interpolated. - -.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. - -.PP -Specifying one of the commands below makes \fBimapsync\fR perform an -action other than the default QRESYNC-based synchronization. - -.TP -.B \-\-repair \fR[\fIMAILBOX\fR ...] -List the database anomalies and try to repair them. -(Consider only the given \fIMAILBOX\fRes if non-optional arguments are -provided.) -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 \-\-delete \fIMAILBOX\fR [...] -Delete the given \fIMAILBOX\fRes on each target (by default each server -plus the database, unless \fB\-\-target\fR specifies otherwise) where -it exists. -Note that per [RFC3501] deletion is not recursive: \fIMAILBOX\fR's -children are not deleted. - -.TP -.B \-\-rename \fISOURCE\fR \fIDEST\fR -Rename the mailbox \fISOURCE\fR to \fIDEST\fR on each target (by default -each server plus the database, unless \fB\-\-target\fR specifies -otherwise) where it exists. -\fBimapsync\fR aborts if \fIDEST\fR already exists on either target. -Note that per [RFC3501] the renaming is recursive: \fISOURCE\fR's -children are moved to become \fIDEST\fR's children instead. - - -.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 \fB\-\-target=\fR{local,remote,database} -Limit the scope of a \fB\-\-delete\fR or \fB\-\-rename\fR command -to the given target. Can be repeated to act on multiple targets. By -default all three targets are considered. - -.TP -.B \-q\fR, \fB\-\-quiet\fR -Try to be quiet. - -.TP -.B \-\-debug -Turn on debug mode. Debug messages are written to the given \fIlogfile\fR. -Note that this include all IMAP traffic (except literals). 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 list-mailbox -A space separated list of mailbox patterns to use when issuing the -initial LIST command (overridden by the \fIMAILBOX\fRes given as -command-line arguments). -Note that each pattern containing special characters such as spaces or -brackets (see [RFC3501] for the exact syntax) must be quoted. -Furthermore, non-ASCII names must be UTF\-7 encoded. -Two wildcards are available: a \(oq*\(cq character matches zero or more -characters, while a \(oq%\(cq character matches zero or more characters -up to the mailbox's hierarchy delimiter. -This option is only available in the default section. -(The default pattern, \(lq*\(rq, matches all visible mailboxes on the -server.) - -.TP -.I list-select-opts -An optional space separated list of selectors for the initial LIST -command. (Requires a server supporting the LIST-EXTENDED [RFC5258] -extension.) Useful values are -\(lqSUBSCRIBED\(rq (to list only subscribed mailboxes), -\(lqREMOTE\(rq (to also list remote mailboxes on a server supporting -mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes -with children matching one of the \fIlist-mailbox\fR patterns above). -This option is only available in the default section. - -.TP -.I ignore-mailbox -An optional Perl Compatible Regular Expressions (PCRE) covering -mailboxes to exclude: -any (UTF-7 encoded, unquoted) mailbox listed in the initial LIST -responses is ignored if it matches the given expression. -Note that the \fIMAILBOX\fRes given as command-line arguments bypass the -check and are always considered for synchronization. -This option is only available in the default section. - -.TP -.I logfile -A file name to use to log debug and informational messages. This option is -only available in the default section. - -.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. -Note that specifying \fItype\fR=tunnel in the \(lq[remote]\(rq section -makes the default \fIdatabase\fR to be \(lqlocalhost.db\(rq. -(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 to 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] -Using \fBimapsync\fR on two identical servers with a non-existent or -empty database will duplicate each message due to the absence of -local/remote UID association. -.IP \[bu] -\fBimapsync\fR is single threaded and doesn't use IMAP command -pipelining. Synchronization could be boosted up by sending independent -commands (such as the initial LIST/STATUS command) to each server in -parallel, and for a given server, by sending independent commands (such -as flag updates) in a pipeline. -.IP \[bu] -Because the IMAP protocol doesn't have a specific response code for when -a message is moved to another mailbox (using the MOVE command from -[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 -Written by Guilhem Moulin -.MT guilhem@fripost.org -.ME . diff --git a/imapsync.sample b/imapsync.sample deleted file mode 100644 index 296f766..0000000 --- a/imapsync.sample +++ /dev/null @@ -1,23 +0,0 @@ -# database = imap.guilhem.org.db -#list-mailbox = "*" -list-select-opts = SUBSCRIBED -ignore-mailbox = ^virtual/ - -[local] -type = tunnel -command = /usr/lib/dovecot/imap - -[remote] -# type = imaps -host = imap.guilhem.org -# port = 993 -username = guilhem -password = xxxxxxxxxxxxxxxx - -# SSL options -#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/imapsync.service b/imapsync.service deleted file mode 100644 index 02b4d13..0000000 --- a/imapsync.service +++ /dev/null @@ -1,12 +0,0 @@ -[Unit] -Description=IMAP-to-IMAP Syncronization service -Wants=network-online.target -After=network-online.target - -[Service] -ExecStart=/usr/bin/imapsync -RestartSec=60s -Restart=always - -[Install] -WantedBy=default.target diff --git a/interimap b/interimap new file mode 100755 index 0000000..6442054 --- /dev/null +++ b/interimap @@ -0,0 +1,1197 @@ +#!/usr/bin/perl -T + +#---------------------------------------------------------------------- +# Fast two-way synchronization program for QRESYNC-capable IMAP servers +# Copyright © 2015 Guilhem Moulin +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#---------------------------------------------------------------------- + +use strict; +use warnings; + +our $VERSION = '0.1'; +my $NAME = 'interimap'; +use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat + bundling auto_version/; +use DBI (); +use List::Util 'first'; + +use lib 'lib'; +use Net::IMAP::InterIMAP qw/read_config compact_set $IMAP_text $IMAP_cond/; + +# Clean up PATH +$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin}; +delete @ENV{qw/IFS CDPATH ENV BASH_ENV/}; + +my %CONFIG; +sub usage(;$) { + my $rv = shift // 0; + if ($rv) { + print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n" + ."Try '$NAME --help' or consult the manpage for more information.\n"; + } + else { + print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n" + ." or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n" + ." or: $NAME [OPTIONS] --delete MAILBOX [..]\n" + ." or: $NAME [OPTIONS] --rename SOURCE DEST\n" + ."Consult the manpage for more information.\n"; + } + exit $rv; +} +usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h repair delete rename/); +usage(0) if $CONFIG{help}; +my $COMMAND = do { + my @command = grep {exists $CONFIG{$_}} qw/repair delete rename/; + usage(1) if $#command>0; + $command[0] +}; +usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND eq 'rename' and $#ARGV != 1); +@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive + + +my $CONF = read_config( delete $CONFIG{config} // $NAME + , [qw/_ local remote/] + , database => qr/\A(\P{Control}+)\z/ + , logfile => qr/\A(\/\P{Control}+)\z/ + , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ + , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/ + , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ + ); +my ($DBFILE, $LOCKFILE, $LOGGER_FD); + +{ + $DBFILE = $CONF->{_}->{database} if defined $CONF->{_}; + $DBFILE //= $CONF->{remote}->{host}.'.db' if defined $CONF->{remote}; + $DBFILE //= $CONF->{local}->{host}. '.db' if defined $CONF->{local}; + die "Missing option database" unless defined $DBFILE; + + unless ($DBFILE =~ /\A\//) { + my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME; + $dir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $dir"; + $dir = $1; + $DBFILE = $dir .'/'. $DBFILE; + unless (-d $dir) { + mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n"; + } + } + + $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r; + + if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) { + require 'POSIX.pm'; + require 'Time/HiRes.pm'; + open $LOGGER_FD, '>>', $CONF->{_}->{logfile} + or die "Can't open $CONF->{_}->{logfile}: $!\n"; + $LOGGER_FD->autoflush(1); + } + elsif ($CONFIG{debug}) { + $LOGGER_FD = \*STDERR; + } +} +my $DBH; + +# Clean after us +sub cleanup() { + logger(undef, "Cleaning up...") if $CONFIG{debug}; + unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE; + close $LOGGER_FD if defined $LOGGER_FD; + $DBH->disconnect() if defined $DBH; +} +$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 1; } foreach qw/INT TERM/; +$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 0; } foreach qw/HUP/; + + +############################################################################# +# Lock the database +{ + if (-f $LOCKFILE) { + open my $lock, '<', $LOCKFILE or die "Can't open $LOCKFILE: $!\n"; + my $pid = <$lock>; + close $lock; + chomp $pid; + my $msg = "LOCKFILE '$LOCKFILE' exists."; + $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/; + die $msg, "\n"; + } + + open my $lock, '>', $LOCKFILE or die "Can't open $LOCKFILE: $!\n"; + print $lock $$, "\n"; + close $lock; +} + + +############################################################################# +# Open the database and create tables + +$DBH = DBI::->connect("dbi:SQLite:dbname=$DBFILE", undef, undef, { + AutoCommit => 0, + RaiseError => 1, + sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not +}); +$DBH->do('PRAGMA foreign_keys = ON'); + + +{ + my @schema = ( + mailboxes => [ + q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT}, + q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE}, + q{subscribed BOOLEAN NOT NULL} + ], + 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}, # 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}, # 0 initially + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL} # 0 initially + # one-to-one correspondence between local.idx and remote.idx + ], + mapping => [ + q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)}, + q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)}, + 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 (except for interrupted syncs) + # mapping.idx must be found among local.idx (and remote.idx) + ], + ); + + # Invariants: + # * UIDVALIDITY never changes. + # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ < + # {local,remote}.HIGHESTMODSEQ have been propagated. + # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT + # (resp. <= remote.UIDNEXT). + # * Any idx in `local` must be present in `remote` and vice-versa. + # * Any idx in `mapping` must be present in `local` and `remote`. + while (@schema) { + my $table = shift @schema; + my $schema = shift @schema; + my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1}); + my $row = $sth->fetch(); + die if defined $sth->fetch(); # sanity check + unless (defined $row) { + $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")"); + $DBH->commit(); + } + } +} + +sub msg($@) { + my $name = shift; + return unless @_; + logger($name, @_) if defined $LOGGER_FD and $LOGGER_FD->fileno != fileno STDERR; + my $prefix = defined $name ? "$name: " : ''; + print STDERR $prefix, @_, "\n"; +} +sub logger($@) { + my $name = shift; + return unless @_ and defined $LOGGER_FD; + my $prefix = ''; + if ($LOGGER_FD->fileno != fileno STDERR) { + my ($s, $us) = Time::HiRes::gettimeofday(); + $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; + } + $prefix .= "$name: " if defined $name; + $LOGGER_FD->say($prefix, @_); +} +logger(undef, ">>> $NAME $VERSION"); + + +############################################################################# +# Connect to the local and remote IMAP servers + +my $IMAP; +foreach my $name (qw/local remote/) { + my %config = %{$CONF->{$name}}; + $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/; + $config{enable} = 'QRESYNC'; + $config{name} = $name; + $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD; + + $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 + + my $list = '"" '; + my @params; + 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; + @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)'); + } + $list .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0]) + : ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV; + @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list($list, @params); +} + + +############################################################################## +# + +# Add a new mailbox to the database. +my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); + +# Get the index associated with a mailbox. +my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?}); + +# Ensure local and remote delimiter match +sub check_delim($) { + my $mbx = shift; + my ($lDelims, $rDelims) = map {$IMAP->{$_}->{delims}} qw/local remote/; + if (exists $lDelims->{$mbx} and exists $rDelims->{$mbx} and + ((defined $lDelims->{$mbx} xor defined $rDelims->{$mbx}) or + (defined $lDelims->{$mbx} and defined $rDelims->{$mbx} and $lDelims->{$mbx} ne $rDelims->{$mbx}))) { + my ($ld, $rd) = ($lDelims->{$mbx}, $rDelims->{$mbx}); + $ld =~ s/([\x22\x5C])/\\$1/g if defined $ld; + $rd =~ s/([\x22\x5C])/\\$1/g if defined $rd; + die "Error: Hierarchy delimiter for $mbx don't match: " + ."local \"". ($ld // '')."\", remote \"".($rd // '')."\"\n" + } + return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef; +} + +# Return true if $mailbox exists on $name +sub mbx_exists($$) { + my ($name, $mailbox) = @_; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0; +} + +# Return true if $mailbox is subscribed to on $name +sub mbx_subscribed($$) { + my ($name, $mailbox) = @_; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0; +} + + +############################################################################## +# Process --delete command +# +if (defined $COMMAND and $COMMAND eq 'delete') { + my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?}); + my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?}); + my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?}); + my $sth_delete_mapping = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ?}); + + foreach my $mailbox (@ARGV) { + $STH_GET_INDEX->execute($mailbox); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + # delete $mailbox on servers where $mailbox exists. note that + # there is a race condition where the mailbox could have + # appeared meanwhile + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + $IMAP->{$name}->{client}->delete($mailbox) if mbx_exists($name, $mailbox); + } + + if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + my $r1 = $sth_delete_mapping->execute($idx); + msg('database', "WARNING: `DELETE FROM mapping WHERE idx = $idx` failed") unless $r1; + my $r2 = $sth_delete_local->execute($idx); + msg('database', "WARNING: `DELETE FROM local WHERE idx = $idx` failed") unless $r2; + my $r3 = $sth_delete_remote->execute($idx); + msg('database', "WARNING: `DELETE FROM remote WHERE idx = $idx` failed") unless $r3; + my $r4 = $sth_delete_mailboxes->execute($idx); + msg('database', "WARNING: `DELETE FROM mailboxes WHERE idx = $idx` failed") unless $r4; + + $DBH->commit(); + msg('database', "Removed mailbox $mailbox") if $r4; + } + } + exit 0; +} + + +############################################################################## +# Process --rename command +# +elsif (defined $COMMAND and $COMMAND eq 'rename') { + my ($from, $to) = @ARGV; + + # get index of the original name + $STH_GET_INDEX->execute($from); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + # ensure the local and remote hierarchy delimiter match + my $delim = check_delim($from); + + # ensure the target name doesn't already exist on the servers. there + # is a race condition where the mailbox would be created before we + # issue the RENAME command, then the server would reply with a + # tagged NO response + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + if (mbx_exists($name, $to)) { + msg($name, "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); + exit 1; + } + } + + # ensure the target name doesn't already exist in the database + $STH_GET_INDEX->execute($to); + if (defined $STH_GET_INDEX->fetch() and + (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + msg('database', "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); + exit 1; + } + + + # rename $from to $to on servers where $from exists. again there is + # a race condition, but if $to has been created meanwhile the server + # will reply with a tagged NO response + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from); + } + + # rename from to $to in the database + if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + my $sth_rename_mailbox = $DBH->prepare(q{UPDATE mailboxes SET mailbox = ? WHERE idx = ?}); + my $r = $sth_rename_mailbox->execute($to, $idx); + msg('database', "WARNING: `UPDATE mailboxes SET mailbox = ".$DBH->quote($to)." WHERE idx = $idx` failed") unless $r; + + # for non-flat mailboxes, rename the children as well + if (defined $delim) { + my $prefix = $from.$delim; + my $sth_rename_children = $DBH->prepare(q{ + UPDATE mailboxes SET mailbox = ? || SUBSTR(mailbox,?) + WHERE SUBSTR(mailbox,1,?) = ? + }); + $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix); + } + + $DBH->commit(); + msg('database', "Renamed mailbox $from to $to") if $r; + } + exit 0; +} + + +############################################################################## +# Synchronize mailbox and subscription lists + +my @MAILBOXES; +{ + my %mailboxes; + $mailboxes{$_} = 1 foreach keys %{$IMAP->{local}->{mailboxes}}; + $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}}; + my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); + + foreach my $mailbox (keys %mailboxes) { + next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox =~ /$CONF->{_}->{'ignore-mailbox'}/o; + my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; + next unless $lExists or $rExists; + + my @attrs = do { + my %attrs = map {$_ => 1} (@{$IMAP->{local}->{mailboxes}->{$mailbox} // []}, + @{$IMAP->{remote}->{mailboxes}->{$mailbox} // []}); + keys %attrs; + }; + + check_delim($mailbox); # ensure that the delimiter match + push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs; + + $STH_GET_INDEX->execute($mailbox); + my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + if ($lExists and $rExists) { + # $mailbox exists on both sides + my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/; + if (defined $idx) { + if ($lSubscribed xor $rSubscribed) { + # mailbox is subscribed on only one server + if ($subscribed) { # unsubscribe + my $name = $lSubscribed ? 'local' : 'remote'; + $IMAP->{$name}->{client}->unsubscribe($mailbox); + } + else { # subscribe + my $name = $lSubscribed ? 'remote' : 'local'; + $IMAP->{$name}->{client}->subscribe($mailbox); + } + # toggle subscribtion in the database + $subscribed = $subscribed ? 0 : 1; + $sth_subscribe->execute($subscribed, $idx) or + msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $subscribed WHERE idx = $idx` failed"); + $DBH->commit(); + } + # $mailbox is either subscribed on both servers, or subscribed on both + elsif ($lSubscribed xor $subscribed) { + # update the database if needed + $sth_subscribe->execute($lSubscribed, $idx) or + msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $lSubscribed WHERE idx = $idx` failed"); + $DBH->commit(); + } + } + else { + # add new mailbox; subscribe on both servers if $mailbox is subscribed on one of them + my $subscribed = ($lSubscribed or $rSubscribed) ? 1 : 0; + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed and !$lSubscribed; + $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed and !$rSubscribed; + $DBH->commit(); + } + } + elsif ($lExists and !$rExists) { + # $mailbox is on 'local' only + if (defined $idx) { + msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); + exit 1; + } + my $subscribed = mbx_subscribed('local', $mailbox); + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{remote}->{client}->create($mailbox, 1); + $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed; + $DBH->commit(); + } + elsif (!$lExists and $rExists) { + # $mailbox is on 'remote' only + if (defined $idx) { + msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); + exit 1; + } + my $subscribed = mbx_subscribed('remote', $mailbox); + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{local}->{client}->create($mailbox, 1); + $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed; + $DBH->commit(); + } + } +} +my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/; +undef $IMAP; + + +############################################################################# +# Synchronize messages + +# Get all cached states from the database. +my $STH_GET_CACHE = $DBH->prepare(q{ + SELECT mailbox, m.idx AS idx, + l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ, + r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ + FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx +}); +my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{ + SELECT mailbox, + l.UIDVALIDITY AS lUIDVALIDITY, l.UIDNEXT AS lUIDNEXT, l.HIGHESTMODSEQ AS lHIGHESTMODSEQ, + r.UIDVALIDITY AS rUIDVALIDITY, r.UIDNEXT AS rUIDNEXT, r.HIGHESTMODSEQ AS rHIGHESTMODSEQ + FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx + WHERE m.idx = ? +}); + +# Find local/remote UID from the map. +my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?}); +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! +my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?}); + +# Update the HIGHESTMODSEQ. +my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?}); +my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?}); + +# Update the HIGHESTMODSEQ and UIDNEXT. +my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); +my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); + +# Add a new mailbox. +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) +}); + +# Count messages +my $STH_COUNT_MESSAGES = $DBH->prepare(q{SELECT COUNT(*) FROM mapping WHERE idx = ?}); + +# List last 1024 messages UIDs +my $STH_LASTUIDs_LOCAL = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? ORDER BY lUID DESC LIMIT 1024}); +my $STH_LASTUIDs_REMOTE = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? ORDER BY rUID DESC LIMIT 1024}); + + +# Download some missing UIDs from $source; returns the thew allocated UIDs +sub download_missing($$$@) { + my $idx = shift; + my $mailbox = shift; + my $source = shift; + my @set = @_; + my @uids; + + my $target = $source eq 'local' ? 'remote' : 'local'; + + 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 eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) { + my $mail = shift; + return unless exists $mail->{RFC822}; # not for us + + 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] : ''; + msg(undef, "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet}; + + 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); + msg(undef, "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ". + "and remote UID $rUID ($rFlags). Setting both to the union ($flags)."); + + return $flags +} + + +# 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 + msg('database', "WARNING: Can't delete (idx,lUID) = ($idx,$lUID)") if $r == 0; +} + + +# Create a sample (sequence numbers, UIDs) to use as Message Sequence +# Match Data for the QRESYNC parameter to the SELECT command. +# QRESYNC [RFC7162] doesn't force the server to remember the MODSEQs of +# EXPUNGEd messages. By passing a sample of known sequence numbers/UIDs +# we let the server know that the messages have been EXPUNGEd [RFC7162, +# section 3.2.5.2]. +# The UID set is the largest set of higest UIDs with at most 1024 UIDs, +# of length (after compacting) at most 64. +# The reason why we sample with the highest UIDs is that lowest UIDs are +# less likely to be deleted. +sub sample($$$) { + my ($idx, $count, $sth) = @_; + return unless $count > 0; + + my ($n, $uids, $min, $max); + $sth->execute($idx); + while (defined (my $row = $sth->fetchrow_arrayref())) { + my $k = $row->[0]; + if (!defined $min and !defined $max) { + $n = 0; + $min = $max = $k; + } + elsif ($k == $min - 1) { + $min--; + } + else { + $n += $max - $min + 1; + $uids = ($min == $max ? $min : "$min:$max") + .(defined $uids ? ','.$uids : ''); + $min = $max = $k; + if (length($uids) > 64) { + $sth->finish(); # done with the statement + last; + } + } + } + if (!defined $uids or length($uids) <= 64) { + $n += $max - $min + 1; + $uids = ($min == $max ? $min : "$min:$max") + .(defined $uids ? ','.$uids : ''); + } + return ( ($count - $n + 1).':'.$count, $uids ); +} + + +# Issue a SELECT command with the given $mailbox. +sub select_mbx($$) { + my ($idx, $mailbox) = @_; + + $STH_COUNT_MESSAGES->execute($idx); + my ($count) = $STH_COUNT_MESSAGES->fetchrow_array(); + die if defined $STH_COUNT_MESSAGES->fetch(); # sanity check + + $lIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_LOCAL)); + $rIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_REMOTE)); +} + + +# Check and repair synchronization of a mailbox between the two servers +# (in a very crude way, by downloading all existing UID with their flags) +sub repair($) { + my $mailbox = shift; + + $STH_GET_INDEX->execute($mailbox); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + return unless defined $idx; # not in the database + select_mbx($idx, $mailbox); + + $STH_GET_CACHE_BY_IDX->execute($idx); + my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // return; # no cache + die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check + + # 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; + + # 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); + while (defined (my $row = $STH_GET_MAPPING->fetch())) { + my ($lUID, $rUID) = @$row; + 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 { + # conflict + msg(undef, "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.") + 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 $lModified->{$lUID} and !defined $rModified->{$rUID}) { + unless ($lVanished{$lUID} and $rVanished{$rUID}) { + msg(undef, "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing."); + push @delete_mapping, $lUID; + } + } + elsif (!defined $lModified->{$lUID}) { + push @delete_mapping, $lUID; + if ($lVanished{$lUID}) { + push @rToRemove, $rUID; + } else { + msg("local($mailbox)", "WARNING: UID $lUID disappeared. Downloading remote UID $rUID again."); + push @rMissing, $rUID; + } + } + elsif (!defined $rModified->{$rUID}) { + push @delete_mapping, $lUID; + if ($rVanished{$rUID}) { + push @lToRemove, $lUID; + } else { + msg("remote($mailbox)", "WARNING: UID $rUID disappeared. Downloading local UID $lUID again."); + push @lMissing, $lUID; + } + } + + delete $lModified->{$lUID}; + delete $lVanished{$lUID}; + delete $rModified->{$rUID}; + delete $rVanished{$rUID}; + } + + # 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; + + # 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. + my @lDunno = keys %lVanished; + my @rDunno = keys %rVanished; + msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " + .compact_set(@lDunno).". Ignoring.") if @lDunno; + msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " + .compact_set(@rDunno).". Ignoring.") if @rDunno; + + foreach my $lUID (keys %$lModified) { + msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Downloading again."); + push @lMissing, $lUID; + } + foreach my $rUID (keys %$rModified) { + msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Downloading again."); + 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); +} + + +# Sync known messages. Since pull_updates is the last method call on +# $lIMAP and $rIMAP, it is safe to call get_cache on either object after +# this function, in order to update the HIGHESTMODSEQ. +# Return true if an update was detected, and false otherwise +sub sync_known_messages($$) { + my ($idx, $mailbox) = @_; + my $update = 0; + + # loop since processing might produce VANISHED or unsollicited FETCH responses + while (1) { + my ($lVanished, $lModified, $rVanished, $rModified); + + ($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; + $update = 1; + + # process VANISHED messages + # /!\ this might modify the VANISHED or MODIFIED cache! + if (@$lVanished or @$rVanished) { + my %lVanished = map {$_ => 1} @$lVanished; + my %rVanished = map {$_ => 1} @$rVanished; + + # For each vanished UID, get the corresponding one on the + # other side (from the DB); consider it as to be removed if + # it hasn't been removed already. + + my (@lToRemove, @rToRemove, @lDunno, @rDunno); + foreach my $lUID (@$lVanished) { + $STH_GET_REMOTE_UID->execute($idx, $lUID); + my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); + die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check + if (!defined $rUID) { + push @lDunno, $lUID; + } + elsif (!exists $rVanished{$rUID}) { + push @rToRemove, $rUID; + } + } + foreach my $rUID (@$rVanished) { + $STH_GET_LOCAL_UID->execute($idx, $rUID); + my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); + die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check + if (!defined $lUID) { + push @rDunno, $rUID; + } + elsif (!exists $lVanished{$lUID}) { + push @lToRemove, $lUID; + } + } + + msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " + .compact_set(@lDunno).". Ignoring.") if @lDunno; + msg("local($mailbox)", "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " + .compact_set(@rDunno).". Ignoring.") if @rDunno; + + $lIMAP->remove_message(@lToRemove) if @lToRemove; + $rIMAP->remove_message(@rToRemove) if @rToRemove; + + # remove existing mappings + foreach my $lUID (@$lVanished, @lToRemove) { + delete_mapping($idx, $lUID); + } + } + + # process FLAG updates + # /!\ this might modify the VANISHED or MODIFIED cache! + if (%$lModified or %$rModified) { + my (%lToUpdate, %rToUpdate); + + # Take flags updates on both sides, and get the + # corresponding UIDs on the other side (from the DB). + # If it wasn't modified there, make it such; if it was + # modified with the same flags list, ignore that message; + # otherwise there is a conflict, and take the union. + # + # Group by flags in order to limit the number of round + # trips. + + while (my ($lUID,$lFlags) = each %$lModified) { + $STH_GET_REMOTE_UID->execute($idx, $lUID); + my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array(); + die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check + if (!defined $rUID) { + msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Try '--repair'."); + } + elsif (defined (my $rFlags = $rModified->{$rUID})) { + unless ($lFlags eq $rFlags) { + my $flags = flag_conflict($mailbox, $lUID => $lFlags, $rUID => $rFlags); + $lToUpdate{$flags} //= []; + push @{$lToUpdate{$flags}}, $lUID; + $rToUpdate{$flags} //= []; + push @{$rToUpdate{$flags}}, $rUID; + } + } + else { + $rToUpdate{$lFlags} //= []; + push @{$rToUpdate{$lFlags}}, $rUID; + } + } + while (my ($rUID,$rFlags) = each %$rModified) { + $STH_GET_LOCAL_UID->execute($idx, $rUID); + my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array(); + die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check + if (!defined $lUID) { + msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Try '--repair'."); + } + elsif (!exists $lModified->{$lUID}) { + # conflicts are taken care of above + $lToUpdate{$rFlags} //= []; + push @{$lToUpdate{$rFlags}}, $lUID; + } + } + + while (my ($lFlags,$lUIDs) = each %lToUpdate) { + $lIMAP->push_flag_updates($lFlags, @$lUIDs); + } + while (my ($rFlags,$rUIDs) = each %rToUpdate) { + $rIMAP->push_flag_updates($rFlags, @$rUIDs); + } + } + } +} + + +# 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) { + msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})"); + return; + } + + 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; +} + + +# 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) = @_; + + 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 + + my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID); + for (my $k=0; $k<=$#messages; $k++) { + logger(undef, "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox") + if $CONFIG{debug}; + $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]); + } + $DBH->commit(); # commit only once per batch + + return @tUID; +} + + +# 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 %ignore = (local => ($lIgnore // []), remote => ($rIgnore // [])); + my $loop; + do { + # get new messages from $source (except @{$ignore{$source}}) and APPEND them to $target + foreach my $source (qw/remote local/) { # pull remote mails first + my $target = $source eq 'remote' ? 'local' : 'remote'; + my $buff = [] unless ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND'); + my $bufflen = 0; + my @tUIDs; + + ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages(sub($) { + callback_new_message($idx, $mailbox, $source, shift, \@tUIDs, $buff, \$bufflen) + }, @{$ignore{$source}}); + + push @tUIDs, callback_new_message_flush($idx, $mailbox, $source, @$buff) + if defined $buff and @$buff; + push @{$ignore{$target}}, @tUIDs; + + $loop = @tUIDs ? 1 : 0; + } + # since $source modifies $target's UIDNEXT upon new mails, we + # need to check again the first $source (remote) whenever the + # last one (local) added new messages to it + } + while ($loop); + + # 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) or + msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox"); + $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $idx) or + msg('database', "WARNING: Can't update remote UIDNEXT/HIGHESTMODSEQ for $mailbox"); + $DBH->commit(); +} + + +# 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). +# +my ($MAILBOX, $IDX); +$STH_LIST_INTERRUPTED->execute(); +while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { + next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailbox + ($IDX, $MAILBOX) = @$row; + msg(undef, "Resuming interrupted sync for $MAILBOX"); + + 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. +# +my %KNOWN_INDEXES; +$STH_GET_CACHE->execute(); +while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { + next unless grep {$row->{mailbox} eq $_} @MAILBOXES; + $lIMAP->set_cache($row->{mailbox}, + UIDVALIDITY => $row->{lUIDVALIDITY}, + UIDNEXT => $row->{lUIDNEXT}, + HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ} + ); + $rIMAP->set_cache($row->{mailbox}, + UIDVALIDITY => $row->{rUIDVALIDITY}, + UIDNEXT => $row->{rUIDNEXT}, + HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ} + ); + $KNOWN_INDEXES{$row->{idx}} = 1; +} + +if (defined $COMMAND and $COMMAND eq 'repair') { + repair($_) foreach @MAILBOXES; + exit 0; +} + + +while(1) { + while(@MAILBOXES) { + 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); + } + else { + $MAILBOX = $lIMAP->next_dirty_mailbox(@MAILBOXES) // $rIMAP->next_dirty_mailbox(@MAILBOXES) // last; + $MAILBOX = 'INBOX' if uc $MAILBOX eq 'INBOX'; # INBOX is case insensitive + + $STH_GET_INDEX->execute($MAILBOX); + ($IDX) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + die unless defined $IDX; # sanity check; + + select_mbx($IDX, $MAILBOX); + + if (!$KNOWN_INDEXES{$IDX}) { + $STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX)); + $STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX)); + + # no need to commit before the first mapping (lUID,rUID) + $KNOWN_INDEXES{$IDX} = 1; + } + 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) or + msg('database', "WARNING: Can't update local HIGHESTMODSEQ for $MAILBOX"); + $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $IDX) or + msg('database', "WARNING: Can't update remote HIGHESTMODSEQ for $MAILBOX"); + $DBH->commit(); + } + sync_messages($IDX, $MAILBOX); + } + } + # clean state! + exit 0 unless defined $COMMAND and $COMMAND eq 'watch'; + wait_notifications(900); +} + +END { + $_->logout() foreach grep defined, ($lIMAP, $rIMAP); + cleanup(); +} diff --git a/interimap.1 b/interimap.1 new file mode 100644 index 0000000..00b87e3 --- /dev/null +++ b/interimap.1 @@ -0,0 +1,334 @@ +.TH INTERIMAP "1" "JULY 2015" "InterIMAP" "User Commands" + +.SH NAME +InterIMAP \- Fast two-way synchronization program for QRESYNC-capable +IMAP servers + +.SH SYNOPSIS +.B interimap\fR [\fIOPTION\fR ...] [\fICOMMAND\fR] [\fIMAILBOX\fR ...] + + +.SH DESCRIPTION +.PP +.B InterIMAP\fR performs stateful synchronization between two IMAP4rev1 +servers. +Such synchronization is made possible by the QRESYNC extension from +[RFC7162]; for convenience reasons servers must also support +LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315]. +Furthermore, while \fBInterIMAP\fR can work with servers lacking support +for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions +greatly improve performance by reducing the number of required round +trips hence are recommended. + +.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 +\fBInterIMAP\fR to abort. +Furthermore, because UIDs are allocated not by the client but by the +server, \fBInterIMAP\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] 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 \fBInterIMAP\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 value 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 value 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. + +.SH COMMANDS +.PP +By default \fBInterIMAP\fR synchronizes each mailbox listed by the +\(lqLIST "" "*"\(rq IMAP command; +the \fIlist-mailbox\fR, \fIlist-select-opts\fR and \fIignore-mailbox\fR +options from the configuration file can be used to shrink that list and +save bandwidth. +However if some extra argument are provided on the command line, +\fBInterIMAP\fR ignores said options and synchronizes the given +\fIMAILBOX\fRes instead. Note that each \fIMAILBOX\fR is taken \(lqas +is\(rq; in particular, it must be UTF-7 encoded, unquoted, and the list +wildcards \(oq*\(cq and \(oq%\(cq are not interpolated. + +.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), \fBInterIMAP\fR performs a \(lqfull +synchronization\(rq on theses messages only: +downloading the whole UID and flag lists on each servers allows +\fBInterIMAP\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, +\fBInterIMAP\fR resumes the synchronization for the rest of the mailbox. + +.PP +Specifying one of the commands below makes \fBInterIMAP\fR perform an +action other than the default QRESYNC-based synchronization. + +.TP +.B \-\-repair \fR[\fIMAILBOX\fR ...] +List the database anomalies and try to repair them. +(Consider only the given \fIMAILBOX\fRes if non-optional arguments are +provided.) +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 \-\-delete \fIMAILBOX\fR [...] +Delete the given \fIMAILBOX\fRes on each target (by default each server +plus the database, unless \fB\-\-target\fR specifies otherwise) where +it exists. +Note that per [RFC3501] deletion is not recursive: \fIMAILBOX\fR's +children are not deleted. + +.TP +.B \-\-rename \fISOURCE\fR \fIDEST\fR +Rename the mailbox \fISOURCE\fR to \fIDEST\fR on each target (by default +each server plus the database, unless \fB\-\-target\fR specifies +otherwise) where it exists. +\fBInterIMAP\fR aborts if \fIDEST\fR already exists on either target. +Note that per [RFC3501] the renaming is recursive: \fISOURCE\fR's +children are moved to become \fIDEST\fR's children instead. + + +.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 \fB\-\-target=\fR{local,remote,database} +Limit the scope of a \fB\-\-delete\fR or \fB\-\-rename\fR command +to the given target. Can be repeated to act on multiple targets. By +default all three targets are considered. + +.TP +.B \-q\fR, \fB\-\-quiet\fR +Try to be quiet. + +.TP +.B \-\-debug +Turn on debug mode. Debug messages are written to the given \fIlogfile\fR. +Note that this include all IMAP traffic (except literals). 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, +\fBInterIMAP\fR reads its configuration from +\fI$XDG_CONFIG_HOME/interimap\fR (or \fI~/.config/interimap\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/interimap\fR, or +\fI~/.local/share/interimap\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 list-mailbox +A space separated list of mailbox patterns to use when issuing the +initial LIST command (overridden by the \fIMAILBOX\fRes given as +command-line arguments). +Note that each pattern containing special characters such as spaces or +brackets (see [RFC3501] for the exact syntax) must be quoted. +Furthermore, non-ASCII names must be UTF\-7 encoded. +Two wildcards are available: a \(oq*\(cq character matches zero or more +characters, while a \(oq%\(cq character matches zero or more characters +up to the mailbox's hierarchy delimiter. +This option is only available in the default section. +(The default pattern, \(lq*\(rq, matches all visible mailboxes on the +server.) + +.TP +.I list-select-opts +An optional space separated list of selectors for the initial LIST +command. (Requires a server supporting the LIST-EXTENDED [RFC5258] +extension.) Useful values are +\(lqSUBSCRIBED\(rq (to list only subscribed mailboxes), +\(lqREMOTE\(rq (to also list remote mailboxes on a server supporting +mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes +with children matching one of the \fIlist-mailbox\fR patterns above). +This option is only available in the default section. + +.TP +.I ignore-mailbox +An optional Perl Compatible Regular Expressions (PCRE) covering +mailboxes to exclude: +any (UTF-7 encoded, unquoted) mailbox listed in the initial LIST +responses is ignored if it matches the given expression. +Note that the \fIMAILBOX\fRes given as command-line arguments bypass the +check and are always considered for synchronization. +This option is only available in the default section. + +.TP +.I logfile +A file name to use to log debug and informational messages. This option is +only available in the default section. + +.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 \fBInterIMAP\fR to open a pipe to a +\fIcommand\fR instead of a raw socket. +Note that specifying \fItype\fR=tunnel in the \(lq[remote]\(rq section +makes the default \fIdatabase\fR to be \(lqlocalhost.db\(rq. +(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 to a secure +connection. Setting this to \(lqYES\(rq for a server not advertising +the \(lqSTARTTLS\(rq capability causes \fBInterIMAP\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. +\fBInterIMAP\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 \fBInterIMAP\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] +Using \fBInterIMAP\fR on two identical servers with a non-existent or +empty database will duplicate each message due to the absence of +local/remote UID association. +.IP \[bu] +\fBInterIMAP\fR is single threaded and doesn't use IMAP command +pipelining. Synchronization could be boosted up by sending independent +commands (such as the initial LIST/STATUS command) to each server in +parallel, and for a given server, by sending independent commands (such +as flag updates) in a pipeline. +.IP \[bu] +Because the IMAP protocol doesn't have a specific response code for when +a message is moved to another mailbox (using the MOVE command from +[RFC6851] or COPY + STORE + EXPUNGE), moving a messages causes +\fBInterIMAP\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 +Written by Guilhem Moulin +.MT guilhem@fripost.org +.ME . diff --git a/interimap.sample b/interimap.sample new file mode 100644 index 0000000..296f766 --- /dev/null +++ b/interimap.sample @@ -0,0 +1,23 @@ +# database = imap.guilhem.org.db +#list-mailbox = "*" +list-select-opts = SUBSCRIBED +ignore-mailbox = ^virtual/ + +[local] +type = tunnel +command = /usr/lib/dovecot/imap + +[remote] +# type = imaps +host = imap.guilhem.org +# port = 993 +username = guilhem +password = xxxxxxxxxxxxxxxx + +# SSL options +#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/interimap.service b/interimap.service new file mode 100644 index 0000000..7f2d035 --- /dev/null +++ b/interimap.service @@ -0,0 +1,12 @@ +[Unit] +Description=Fast two-way synchronization program for QRESYNC-capable IMAP servers +Wants=network-online.target +After=network-online.target + +[Service] +ExecStart=/usr/bin/interimap +RestartSec=60s +Restart=always + +[Install] +WantedBy=default.target diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm new file mode 100644 index 0000000..26cfbbd --- /dev/null +++ b/lib/Net/IMAP/InterIMAP.pm @@ -0,0 +1,1617 @@ +#---------------------------------------------------------------------- +# A minimal IMAP4 client for QRESYNC-capable servers +# Copyright © 2015 Guilhem Moulin +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#---------------------------------------------------------------------- + +package Net::IMAP::InterIMAP v0.0.1; +use warnings; +use strict; + +use Config::Tiny (); +use IO::Select (); +use List::Util 'first'; +use Socket 'SO_KEEPALIVE'; + +use Exporter 'import'; +BEGIN { + our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/; +} + + +# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'. +my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/; +my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; +my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; + +# Map each option to a regexp validating its values. +my %OPTIONS = ( + host => qr/\A([0-9a-zA-Z:.-]+)\z/, + port => qr/\A([0-9]+)\z/, + 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/, + SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, + 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/, +); + + +############################################################################# +# Utilities + +# read_config($conffile, $sections, %opts) +# Read $conffile's default section, then each section in the array +# reference $section (which takes precedence). %opts extends %OPTIONS +# and maps each option to a regexp validating its values. +sub read_config($$%) { + my $conffile = shift; + my $sections = shift; + my %opts = (%OPTIONS, @_); + + $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile + unless $conffile =~ /\A\//; # relative path + + die "No such config file $conffile\n" + unless defined $conffile and -f $conffile and -r $conffile; + + my $h = Config::Tiny::->read($conffile); + + my %configs; + foreach my $section (@$sections) { + my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section + $configs{$section} = $conf; + + if ($section ne '_') { + die "No such section $section\n" unless defined $h->{$section}; + $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}}; + } + + # default values + $conf->{type} //= 'imaps'; + $conf->{host} //= 'localhost'; + $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef; + $conf->{auth} //= 'PLAIN LOGIN'; + $conf->{STARTTLS} //= 'YES'; + + # untaint and validate the config + foreach my $k (keys %$conf) { + die "Invalid option $k\n" unless defined $opts{$k}; + next unless defined $conf->{$k}; + die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k}; + $conf->{$k} = $1; + } + } + return \%configs; +} + + +# compact_set(@set). +# Compact the UID or sequence number set @set, which must be +# non-empty and may not contain '*'. (Duplicates are allowed, but +# are removed). +sub compact_set(@) { + my @set = sort {$a <=> $b} @_; + my $min = my $max = shift @set // die 'Empty range'; + my $set; + + while (@set) { + my $k = shift @set; + if ($k < $max) { + die "Non-sorted range: $k < $max"; # sanity check + } + elsif ($k == $max) { # skip duplicates + } + elsif ($k == $max + 1) { + $max++; + } + else { + $set .= ',' if defined $set; + $set .= $min == $max ? $min : "$min:$max"; + $min = $max = $k; + } + } + + $set .= ',' if defined $set; + $set .= $min == $max ? $min : "$min:$max"; + return $set; +} + + +# in_set($x, $set) +# Return true if the UID or sequence number $x belongs to the set $set. +# /!\ The highest number in the mailbox, "*" should not appear by +# itself (other than in a range). +sub in_set($$) { + my ($x, $set) = @_; + foreach my $r (split /,/, $set) { + if ($r =~ /\A([0-9]+)\z/) { + return 1 if $x == $1; + } + elsif ($r eq '*' or $r eq '*:*') { + warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)"; + return 1; + } + elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) { + return 1 if $1 <= $x; + } + elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) { + my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1); + return 1 if $min <= $x and $x <= $max; + } + } + return 0; +} + + +# quote($str) +# Quote the given string if needed, or make it a (synchronizing) +# literal. The literals will later be made non-synchronizing if the +# server is LITERAL+-capable (RFC 2088). +sub quote($) { + my $str = shift; + if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) { + return $str; + } + elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) { + $str =~ s/([\x22\x5C])/\\$1/g; + return "\"$str\""; + } + else { + return "{".length($str)."}\r\n".$str; + } +} + + + +############################################################################# +# Public interface +# /!\ While this module can be used with non QRESYNC-capable (or non +# QRESYNC-enabled) servers, there is no internal cache mapping sequence +# numbers to UIDs, so EXPUNGE responses are ignored. + +# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status +# ('OK'/'NO'/'BAD') condition for the last command issued. +our $IMAP_cond; + +# The response text for the last command issued (prefixed with the status +# condition but without the tag). +our $IMAP_text; + + +# Create a new Net::IMAP::InterIMAP object. Connect to the server, +# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and +# update the CAPABILITY list. +# In addition to the %OPTIONS above, valid parameters include: +# +# - 'debug': Enable debug messages. +# +# - 'enable': An extension or array reference of extensions to ENABLE +# (RFC 5161) after entering AUTH state. Croak if the server did not +# advertise "ENABLE" in its CAPABILITY list or does not reply with +# an untagged ENABLED response with all the given extensions. +# +# - 'name': An optional instance name to include in log messages. +# +# - 'extra-attrs': An attribute or list of extra attributes to FETCH +# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE +# BODY.PEEK[]). +# +# - 'logger-fd': An optional filehandle to use for debug output. +# +sub new($%) { + my $class = shift; + my $self = { @_ }; + bless $self, $class; + + # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' + # (cf RFC 3501 section 3) + $self->{_STATE} = ''; + + if ($self->{type} eq 'tunnel') { + require 'IPC/Open2.pm'; + 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 { + my %args = (Proto => 'tcp', Blocking => 1); + $args{PeerHost} = $self->{host} // $self->fail("Missing option host"); + $args{PeerPort} = $self->{port} // $self->fail("Missing option port"); + + my $socket; + if ($self->{type} eq 'imap') { + require 'IO/Socket/INET.pm'; + $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@"); + } + else { + require 'IO/Socket/SSL.pm'; + 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; + $socket = IO::Socket::SSL->new(%args) + or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); + + # ensure we're talking to the right server + $self->_fingerprint_match($socket, $fpr) if defined $fpr; + } + + $socket->sockopt(SO_KEEPALIVE, 1); + $self->{$_} = $socket for qw/STDOUT STDIN/; + } + $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!"); + + # command counter + $self->{_TAG} = 0; + + # internal cache, constantly updated to reflect the current server + # state for each mailbox + $self->{_CACHE} = {}; + + # persistent cache, describing the last clean (synced) state + $self->{_PCACHE} = {}; + + # list of UIDs for which the server a VANISHED or VANISHED (EARLIER) + # response. /!\ requires a QRESYNC-capable server! + # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} + # are considered. + $self->{_VANISHED} = []; + + # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH + # response with the FLAGS attribute. The \Recent flag is always + # omitted from the FLAG list. MODSEQ is always present, and the + # value [ MODSEQ, FLAGS ] is updated if another FETCH response with + # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG + # list of the message is considered unknown and should be retrieved + # manually. + # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} + # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} + # are considered. + $self->{_MODIFIED} = {}; + + if (defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR) { + require 'POSIX.pm'; + require 'Time/HiRes.pm'; + } + + # wait for the greeting + my $x = $self->_getline(); + $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x); + $IMAP_cond = $1; + $IMAP_text = $1.' '.$x; + + # try to update the cache (eg, capabilities) + $self->_resp_text($x); + + if ($IMAP_cond eq 'OK') { + # login required + $self->{_STATE} = 'UNAUTH'; + my @caps = $self->capabilities(); + + 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_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; + IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs) + or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); + + # ensure we're talking to the right server + $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr; + + # refresh the previous CAPABILITY list since the previous one could have been spoofed + delete $self->{_CAPABILITIES}; + @caps = $self->capabilities(); + } + + my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps); + my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef} + split(/ /, $self->{auth}))[0]; + $self->fail("Failed to choose an authentication mechanism") unless defined $mech; + $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and + grep {$_ eq 'LOGINDISABLED'} @caps; + + my ($command, $callback); + my ($username, $password) = @$self{qw/username password/}; + + if ($mech eq 'LOGIN') { + $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; + $command = join ' ', 'LOGIN', quote($username), quote($password); + } + elsif ($mech eq 'PLAIN') { + require 'MIME/Base64.pm'; + $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; + my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); + $command = "AUTHENTICATE $mech"; + if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR + $command .= " $credentials"; + } else { + $callback = sub($) {return $credentials}; + } + } + else { + $self->fail("Unsupported authentication mechanism: $mech"); + } + + delete $self->{password}; # no need to remember passwords + $self->_send($command, $callback); + unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) { + # refresh the CAPABILITY list since the previous one had only pre-login capabilities + delete $self->{_CAPABILITIES}; + $self->capabilities(); + } + } + + $self->{_STATE} = 'AUTH'; + my @extensions = !defined $self->{enable} ? () + : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}} + : ($self->{enable}); + if (@extensions) { + $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("Couldn't ENABLE $_") foreach + grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; + } + + return $self; +} + + +# Log out when the Net::IMAP::InterIMAP object is destroyed. +sub DESTROY($) { + my $self = shift; + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + } +} + + +# $self->log($message, [...]) +# $self->logger($message, [...]) +# Log a $message. The latter method is used to log in the 'logger-fd', and +# add timestamps. +sub log($@) { + my $self = shift; + return unless @_; + $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR; + my $prefix = defined $self->{name} ? $self->{name} : ''; + $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; + print STDERR $prefix, ': ', @_, "\n"; +} +sub logger($@) { + my $self = shift; + return unless @_ and defined $self->{'logger-fd'}; + my $prefix = ''; + if ($self->{'logger-fd'}->fileno != fileno STDERR) { + my ($s, $us) = Time::HiRes::gettimeofday(); + $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; + } + $prefix .= defined "$self->{name}" ? $self->{name} : ''; + $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; + $self->{'logger-fd'}->say($prefix, ': ', @_); +} + + +# $self->warn($warning, [...]) +# Log a $warning. +sub warn($$@) { + my $self = shift; + $self->log('WARNING: ', @_); +} + + +# $self->fail($error, [...]) +# Log an $error and exit with return value 1. +sub fail($$@) { + my $self = shift; + $self->log('ERROR: ', @_); + exit 1; +} + + +# $self->panic($error, [...]) +# Log a fatal $error including the position of the caller, and exit +# with return value 255. +sub panic($@) { + my $self = shift; + my @loc = caller; + my $msg = "PANIC at line $loc[2] in $loc[1]"; + $msg .= ': ' if @_; + $self->log($msg, @_); + exit 255; +} + + +# $self->capabilities() +# Return the capability list of the IMAP4 server. The list is cached, +# and a CAPABILITY command is only issued if the cache is empty. +sub capabilities($) { + my $self = shift; + $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}}; + $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1'); + return @{$self->{_CAPABILITIES}}; +} + + +# $self->incapable(@capabilities) +# In list context, return the list capabilties from @capabilities +# which were NOT advertised by the server. In scalar context, return +# the length of said list. +sub incapable($@) { + my ($self, @caps) = @_; + my @mycaps = $self->capabilities(); + grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps; +} + + +# $self->search($criterion) +# Issue an UID SEARCH command with the given $criterion. Return the +# list of matching UIDs. +sub search($$) { + my ($self, $crit) = @_; + my @res; + $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_}); + return @res +} + + +# $self->select($mailbox, [$seqs, $UIDs]) +# $self->examine($mailbox, [$seqs, $UIDs]) +# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, +# change the state to SELECTED, otherwise go back to AUTH. +# The optional $seqs and $UIDs are used as Message Sequence Match +# Data for the QRESYNC parameter to the SELECT command. +sub select($$;$$) { + my $self = shift; + my $mailbox = shift; + $self->_select_or_examine('SELECT', $mailbox, @_); +} +sub examine($$;$$) { + my $self = shift; + my $mailbox = shift; + $self->_select_or_examine('EXAMINE', $mailbox, @_); +} + + +# $self->logout() +# Issue a LOGOUT command. Change the state to LOGOUT. +sub logout($) { + my $self = shift; + # don't bother if the connection is already closed + $self->_send('LOGOUT') if $self->{STDIN}->opened(); + $self->{_STATE} = 'LOGOUT'; + undef $self; +} + + +# $self->noop() +# Issue a NOOP command. +sub noop($) { + shift->_send('NOOP'); +} + + +# $self->create($mailbox, [$try]) +# $self->delete($mailbox, [$try]) +# CREATE or DELETE $mailbox. +# If try is set, print a warning but don't crash if the command fails. +sub create($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("CREATE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} +sub delete($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("DELETE ".quote($mailbox)); + delete $self->{_CACHE}->{$mailbox}; + delete $self->{_PCACHE}->{$mailbox}; + if ($IMAP_cond eq 'OK') { + $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} + + +# $self->rename($oldname, $newname, [$try]) +# RENAME the mailbox $oldname to $newname. +# If $try is set, print a warning but don't crash if the command fails. +# /!\ Requires a LIST command to be issued to determine the hierarchy +# delimiter and the mailbox attributes for the original name. +sub rename($$$;$) { + my ($self, $from, $to, $try) = @_; + my ($delim, @attrs); + if ($self->{_CACHE}->{$from}) { + $delim = $self->{_CACHE}->{$from}->{DELIMITER}; + @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []}; + } + my $r = $self->_send("RENAME ".quote($from).' '.quote($to)); + $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from}; + $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from}; + if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) { + # on non-flat mailboxes, move children as well (cf 3501) + foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) { + my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r; + $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1}; + $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1}; + } + } + if ($IMAP_cond eq 'OK') { + $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; + } + else { + my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} + + +# $self->subscribe($mailbox, [$try]) +# $self->unsubscribe($mailbox, [$try]) +# SUBSCRIBE or UNSUBSCRIBE $mailbox. +# If $try is set, print a warning but don't crash if the command fails. +sub subscribe($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} +sub unsubscribe($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} + + +# $self->list($criterion, @parameters) +# Issue a LIST command with the given $criterion and @parameters. +# Return a pair where the first component is a hash reference of +# matching mailboxes and their flags, and the second component is a +# hash reference of matching mailboxes and their hierarchy delimiter +# (or undef for flat mailboxes). +sub list($$@) { + my $self = shift; + my $crit = shift; + my %mailboxes; + my %delims; + $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''), + sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} ); + return (\%mailboxes, \%delims); +} + + +# $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 couldn't be EXPUNGEd. +sub remove_message($@) { + my $self = shift; + my @set = @_; + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") + if $self->incapable('UIDPLUS'); + + my $set = compact_set(@set); + $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)"); + $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS + + my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; + + my (@failed, @expunged); + foreach my $uid (@set) { + if (exists $vanished{$uid}) { + push @expunged, $uid + } else { + push @failed, $uid; + } + } + + # ignore succesfully EXPUNGEd messages + delete @vanished{@expunged}; + delete @{$self->{_MODIFIED}}{@expunged}; + $self->{_VANISHED} = [ keys %vanished ]; + + $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, $mail, [...]) +# Issue an APPEND command with the given mails. Croak if the server +# 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($$@) { + my $self = shift; + my $mailbox = shift; + return unless @_; + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") + if $self->incapable('UIDPLUS'); + + my @appends; + foreach my $mail (@_) { + my $append = ''; + $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 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 + my ($UIDNEXT, $EXISTS, $cache, %vanished); + if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { + $cache = $self->{_CACHE}->{$mailbox}; + $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); + $EXISTS = $cache->{EXISTS} // $self->panic(); + %vanished = map {$_ => 1} @{$self->{_VANISHED}}; + } + + $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends)); + $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text); + my ($uidvalidity, $uidset) = ($1, $2); + $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity); + + my @uids; + foreach (split /,/, $uidset) { + if (/\A([0-9]+)\z/) { + $UIDNEXT = $1 + 1 if defined $UIDNEXT and $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 defined $UIDNEXT and $UIDNEXT <= $max; + } else { + $self->panic($_); + } + } + $self->fail("$uidset contains ".scalar(@uids)." elements while " + .scalar(@appends)." messages were appended.") + unless $#uids == $#appends; + + # if $mailbox is the current mailbox we need to update the cache + if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { + # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required + my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}}; + 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} // 1) < $UIDNEXT; + } + + $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) + unless $self->{quiet}; + return @uids; +} + + +# $self->fetch($set, $flags, [$callback]) +# Issue an UID FETCH command with the given UID $set, $flags, and +# optional $callback. +sub fetch($$$$) { + my ($self, $set, $flags, $callback) = @_; + $self->_send("UID FETCH $set $flags", $callback); +} + + +# $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($@) { + my $self = shift; + $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 + # 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'; + $self->_send($command); + $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT}); +} + + +# $self->slurp() +# 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. +# This is mostly useful when waiting for notifications while no +# command is progress, cf. RFC 5465 (NOTIFY). +sub slurp($) { + my $self = shift; + + my $stdout = $self->{STDOUT}; + my $read = 0; + + while (1) { + # Unprocessed data within the current SSL frame would cause + # select(2) to block/timeout due to the raw socket not being + # ready. + unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) { + my ($ok) = $self->{_SEL_OUT}->can_read(0); + return $read unless defined $ok; + } + + $self->_resp( $self->_getline() ); + $read++; + } +} + + +# $self->set_cache( $mailbox, STATE ) +# Initialize or update the persistent cache, that is, associate a +# known $mailbox with the last known (synced) state: +# * UIDVALIDITY +# * UIDNEXT: Any message the UID of which is at least UIDNEXT is +# considered new and must be downloaded. (If 0 or missing, all +# messages in $mailbox are considered new.) Note that while all +# UIDs in the map are panic(); + my $cache = $self->{_PCACHE}->{$mailbox} //= {}; + + my %status = @_; + while (my ($k, $v) = each %status) { + if ($k eq 'UIDVALIDITY') { + # try to detect UIDVALIDITY changes early (before starting the sync) + $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", + "Need to invalidate the UID cache.") + if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; + } + $cache->{$k} = $v; + } + + $self->logger("Update last clean state for $mailbox: ". + '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')') + if $self->{debug}; +} + + +# $self->uidvalidity([$mailbox]) +# Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to +# its UIDVALIDITY if $mailbox is omitted. +sub uidvalidity($;$) { + my $self = shift; + my $mailbox = shift; + if (defined $mailbox) { + my $cache = $self->{_CACHE}->{$mailbox} // return; + return $cache->{UIDVALIDITY}; + } + else { + my %uidvalidity; + while (my ($mbx,$cache) = each %{$self->{_CACHE}}) { + $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0; + } + return %uidvalidity; + } +} + + +# $self->set_cache(@attributes) +# Return the persistent cache for the mailbox currently selected. If +# some @attributes are given, return the list of values corresponding +# to these attributes. +# /!\ Should only be called right after pull_updates! +# Croak if there are unprocessed VANISHED responses or FLAG updates. +sub get_cache($@) { + my $self = shift; + $self->fail("Invalid method 'get_cache' in state $self->{_STATE}") + unless $self->{_STATE} eq 'SELECTED'; + my $mailbox = $self->{_SELECTED} // $self->panic(); + + $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; + $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}}; + + my $cache = $self->{_PCACHE}->{$mailbox}; + return @_ ? @$cache{@_} : %$cache; +} + + +# $self->is_dirty($mailbox) +# Return true if there are pending updates for $mailbox, i.e., its +# internal cache is newer than its persistent cache. +sub is_dirty($$) { + my ($self, $mailbox) = @_; + my $cache = $self->{_CACHE}->{$mailbox} // return 1; + my $pcache = $self->{_PCACHE}->{$mailbox} // return 1; + + if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ} + and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and + defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT} + and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) { + return 0 + } else { + return 1 + } +} + + +# $self->next_dirty_mailbox(@mailboxes) +# Return the name of a dirty mailbox, or undef if all mailboxes are +# clean. If @mailbox is non-empty, only consider mailboxes in that +# list. +sub next_dirty_mailbox($@) { + my $self = shift; + my %mailboxes = map {$_ => 1} @_; + my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) } + keys %{$self->{_CACHE}}; + if ($self->{debug}) { + @dirty ? $self->logger("Dirty mailboxes: ".join(', ', @dirty)) + : $self->logger("Clean state!"); + } + return $dirty[0]; +} + + +# $self->pull_updates([$full]) +# If $full is set, FETCH FLAGS and MODSEQ for each UID up to +# UIDNEXT-1. +# Get pending updates (unprocessed VANISHED responses and FLAG +# updates), and empty these lists from the cache. +# Finally, update the HIGHESTMODSEQ from the persistent cache to the +# value found in the internal cache. +sub pull_updates($;$) { + my $self = shift; + my $full = shift // 0; + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $pcache = $self->{_PCACHE}->{$mailbox}; + + 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 = (); + } + + # 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}; + + # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT + # since there might be new messages) + $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ}); + + return (\@vanished, \%modified); +} + + +# $self->pull_new_messages($callback, @ignore) +# FETCH new messages since the UIDNEXT found in the persistent cache +# (or 1 in no such UIDNEXT is found), and process each response on the +# fly with the callback. +# If an @ignore list is supplied, then these messages are ignored from +# the UID FETCH range. +# Finally, update the UIDNEXT from the persistent cache to the value +# found in the internal cache. +# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ! +sub pull_new_messages($$@) { + my $self = shift; + my $callback = shift; + my @ignore = sort { $a <=> $b } @_; + my @attrs = !defined $self->{'extra-attrs'} ? () + : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}} + : ($self->{'extra-attrs'}); + my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]'; + + my $mailbox = $self->{_SELECTED} // $self->panic(); + + 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++; + } + } + + $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}); +} + + +# $self->push_flag_updates($flags, @set) +# Change the flags to each UID in @set to $flags. +# A flag update fails for mails being updated after the HIGHESTMODSEQ +# found in the persistent cache; push such messages to the MODIFIED +# list. +sub push_flag_updates($$@) { + my $self = shift; + my $flags = shift; + my @set = @_; + + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic(); + my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; + + my %listed; + $self->_send($command, sub($){ $listed{shift->{UID}}++; }); + + my %failed; + if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { + foreach (split /,/, $1) { + if (/\A([0-9]+)\z/) { + $failed{$1} = 1; + } + elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); + $failed{$_} = 1 foreach ($min .. $max); + } + else { + $self->panic($_); + } + } + } + + my @ok; + foreach my $uid (@set) { + if ($failed{$uid}) { + # $uid was listed in the MODIFIED response code + $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates + delete $self->{_MODIFIED}->{$uid} if + # got a FLAG update for $uid; ignore it if it's $flags + defined $self->{_MODIFIED}->{$uid}->[1] and + $self->{_MODIFIED}->{$uid}->[1] eq $flags; + } + else { + # $uid wasn't listed in the MODIFIED response code + next unless defined $self->{_MODIFIED}->{$uid}; # already stored + $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check + if ($listed{$uid} == 1) { + # ignore succesful update + delete $self->{_MODIFIED}->{$uid}; + } + elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) { + # got multiple FETCH responses for $uid, the last one with $flags + delete $self->{_MODIFIED}->{$uid}; + } + push @ok, $uid; + } + } + + unless ($self->{quiet}) { + $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok; + $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '. + "trying again later") if %failed; + } + return keys %failed; +} + + +############################################################################# +# Private methods + + +# $self->_fingerprint_match($socket, $fingerprint) +# Croak unless the fingerprint of the peer certificate of the +# IO::Socket::SSL object doesn't match the given $fingerprint. +sub _fingerprint_match($$$) { + my ($self, $socket, $fpr) = @_; + + my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256'; + my $fpr2 = $socket->get_fingerprint($algo); + $fpr =~ s/.*\$//; + $fpr2 =~ s/.*\$//; + $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2; +} + + +# $self->_getline([$msg]) +# Read a line from the handle and strip the trailing CRLF. +# /!\ Don't use this method with non-blocking IO! +sub _getline($;$) { + my $self = shift; + my $msg = shift // ''; + + if ($self->{STDOUT}->opened()) { + my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!"); + $x =~ s/\r\n\z// or $self->panic($x); + $self->logger("S: $msg", $x) if $self->{debug}; + return $x; + } + else { + undef $self; + } +} + + +# $self->_update_cache( ATTRIBUTE => VALUE, [...] ) +# Update the internal cache for the currently selected mailbox with +# the given attributes and values. +sub _update_cache($%) { + my $self = shift; + $self->_update_cache_for($self->{_SELECTED}, @_); +} + + +# $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] ) +# Update the internal cache for $mailbox with the given attributes and +# values. +sub _update_cache_for($$%) { + my $self = shift; + my $mailbox = shift // $self->panic(); + my $cache = $self->{_CACHE}->{$mailbox} //= {}; + + my %status = @_; + while (my ($k, $v) = each %status) { + if ($k eq 'UIDVALIDITY') { + # try to detect UIDVALIDITY changes early (before starting the sync) + $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", + "Need to invalidate the UID cache.") + if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; + $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v; + } + $cache->{$k} = $v; + } +} + + +# $self->_send($command, [$callback]) +# Send the given $command to the server, then wait for the response. +# (The status condition and response text are respectively placed in +# $IMAP_cond and $IMAP_text.) Each untagged response received in the +# meantime is read, parsed and processed. The optional $callback, if +# given, is executed with all untagged responses associated with the +# command. +# In void context, croak unless the server answers with a tagged 'OK' +# response. Otherwise, return the condition status ('OK'/'NO'/'BAD'). +sub _send($$;&) { + my ($self, $command, $callback) = @_; + 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; + + # send the command; for servers supporting non-synchronizing + # literals, mark literals as such and then the whole command in one + # go, otherwise send literals one at a time + my $tag = sprintf '%06d', $self->{_TAG}++; + my $litplus; + my @command = ("$tag "); + my $dbg_cmd = "C: $command[0]"; + while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { + my ($str, $len) = ($1, $2); + my $lit = substr $command, 0, $len, ''; # consume the literal + + $litplus //= $self->_capable('LITERAL+') ? '+' : ''; + push @command, $str, "{$len$litplus}", "\r\n"; + $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug}; + $dbg_cmd = 'C: [...]'; + + unless ($litplus) { + $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); + $self->{STDIN}->flush(); + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + @command = (); + } + push @command, $lit; + } + push @command, $command, "\r\n"; + $self->logger($dbg_cmd, $command) if $self->{debug}; + $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); + $self->{STDIN}->flush(); + + + my $r; + # wait for the answer + while (1) { + my $x = $self->_getline(); + if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) { + $IMAP_cond = $1; + $IMAP_text = $1.' '.$x; + $self->_resp_text($x); + $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK'; + $r = $1; + last; + } + else { + $self->_resp($x, $cmd, $set, $callback); + } + } + + if (defined $self->{_SELECTED}) { + my $mailbox = $self->{_SELECTED}; + my $cache = $self->{_CACHE}->{$mailbox}; + # can't keep track of the modification sequences + $self->fail("Mailbox $mailbox doesn't support MODSEQ.") + if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC'); + $self->fail("Mailbox $mailbox does not support persistent UIDs.") + if defined $cache->{UIDNOTSTICKY}; + } + + return $r; +} + + +# $self->_capable($capability, [...]) +# Return true if each $capability is listed in the server's CAPABILITY +# list. +sub _capable($@) { + my $self = shift; + return 0 unless defined $self->{_CAPABILITIES}; + foreach my $cap (@_) { + return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}}; + } + return 1; +} + + +# $self->_capable($extension) +# Return true if $extension has been enabled by the server, i.e., the +# server sent an untagged ENABLED response including it. +sub _enabled($$) { + my $self = shift; + my $ext = uc shift; + grep {$ext eq uc $_} @{$self->{_ENABLED} // []}; +} + + +# $self->_open_mailbox($mailbox) +# Initialize the internal and persistent caches for $mailbox, and mark +# it as selected. +sub _open_mailbox($$) { + my $self = shift; + my $mailbox = shift; + + # it is safe to wipe cached VANISHED responses or FLAG updates, + # because interesting stuff must have made the mailbox dirty so + # we'll get back to it + $self->{_VANISHED} = []; + $self->{_MODIFIED} = {}; + + $self->{_SELECTED} = $mailbox; + $self->{_CACHE}->{$mailbox} //= {}; + + # always reset EXISTS to keep track of new mails + delete $self->{_CACHE}->{$mailbox}->{EXISTS}; +} + + +# $self->_select_or_examine($command, $mailbox, [$seqs, $UIDs]) +# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, +# change the state to SELECTED, otherwise go back to AUTH. +# The optional $seqs and $UIDs are used as Message Sequence Match +# Data for the QRESYNC parameter to the $command. +sub _select_or_examine($$$;$$) { + my $self = shift; + my $command = shift; + my $mailbox = shift; + my ($seqs, $uids) = @_; + + my $pcache = $self->{_PCACHE}->{$mailbox} //= {}; + my $cache = $self->{_CACHE}->{$mailbox} //= {}; + $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY}; + + $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive + $command .= ' '.quote($mailbox); + if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) { + $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " + ."1:".($pcache->{UIDNEXT}-1); + $command .= " ($seqs $uids)" if defined $seqs and defined $uids; + $command .= "))"; + } + + if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { + # 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 + # previous mailbox ($self->{_SELECTED}), while all subsequent + # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. + $self->{_SELECTED_DELAYED} = $mailbox; + } + else { + $self->_open_mailbox($mailbox); + } + + $self->{_STATE} = 'AUTH'; + $self->_send($command); + $self->{_STATE} = 'SELECTED'; +} + + + +############################################################################# +# Parsing methods +# + +# Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed. +sub _resp_text($$) { + my $self = shift; + local $_ = shift; + + if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) { + $self->log($_); + } + elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) { + $self->fail($_); + } + elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) { + $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; + } + elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) { + $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] ); + } + elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) { + $self->_update_cache($1 => 1); + } + elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) { + $self->_update_cache($1 => $2); + } + elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) { + # RFC 4551/7162 CONDSTORE/QRESYNC + $self->_update_cache(HIGHESTMODSEQ => $1); + } + elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) { + # RFC 4551/7162 CONDSTORE/QRESYNC + $self->_update_cache(NOMODSEQ => 1); + } + elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) { + # RFC 7162 CONDSTORE/QRESYNC + # Update the selected mailbox: previous responses refer to the + # previous mailbox ($self->{_SELECTED}), while all subsequent + # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. + my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic(); + $self->_open_mailbox($mailbox); + } + elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) { + # RFC 5465 NOTIFY + $self->fail($_); + } + elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) { + # RFC 4315 UIDPLUS + $self->_update_cache(UIDNOTSTICKY => 1); + } +} + +# Parse and consume an RFC 3501 nstring (string / "NIL"). +sub _nstring($$) { + my ($self, $stream) = @_; + return $$stream =~ s/\ANIL// ? undef : $self->_string($stream); +} + +# Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string). +sub _astring($$) { + my ($self, $stream) = @_; + return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream); +} + +# Parse and consume an RFC 3501 string (quoted / literal). +sub _string($$) { + my ($self, $stream) = @_; + if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) { + # quoted + my $str = $1; + $str =~ s/\\([\x22\x5C])/$1/g; + return $str; + } + elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) { + # literal + $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!"); + # read a the rest of the response + $$stream = $self->_getline('[...]'); + return $lit; + } + else { + $self->panic($$stream); + } +} + +# Parse and consume an RFC 3501 "(" 1*address ")" / "NIL". +sub _addresses($$) { + my ($self, $stream) = @_; + return undef if $$stream =~ s/\ANIL//; + + my @addresses; + $$stream =~ s/\A\(// or $self->panic($$stream); + while ($$stream =~ s/\A ?\(//) { + my @addr; + push @addr, $self->_nstring($stream); # addr-name + $$stream =~ s/\A // or $self->panic($$stream); + push @addr, $self->_nstring($stream); # addr-adl + $$stream =~ s/\A // or $self->panic($$stream); + push @addr, $self->_nstring($stream); # addr-mailbox + $$stream =~ s/\A // or $self->panic($$stream); + push @addr, $self->_nstring($stream); # addr-host + $$stream =~ s/\A\)// or $self->panic($$stream); + push @addresses, \@addr; + } + $$stream =~ s/\A\)// or $self->panic($$stream); + return \@addresses; +} + +# Parse and consume an RFC 3501 envelope +sub _envelope($$) { + my ($self, $stream) = @_; + $$stream =~ s/\A\(// or $self->panic($$stream); + + my @envelope; + push @envelope, $self->_nstring($stream); # env-date + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_nstring($stream); # env-subject + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-from + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-sender + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-reply-to + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-to + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-cc + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-bcc + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_nstring($stream); # env-in-reply-to + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_nstring($stream); # env-message-id + + $$stream =~ s/\A\)// or $self->panic($$stream); + return \@envelope; +} + +# $self->_resp($buf, [$cmd, $callback] ) +# Parse an untagged response line or a continuation request line. +# (The trailing CRLF must be removed.) The internal cache is +# automatically updated when needed. +# If a command and callback are given, the callback is be executed +# for each (parsed) responses associated with the command. +sub _resp($$;$$$) { + my $self = shift; + local $_ = shift; + my $cmd = shift; + my $set = shift; + my $callback = shift; + my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED}; + + if (s/\A\* //) { + if (s/\ABYE //) { + undef $self; + } + elsif (s/\A(?:OK|NO|BAD) //) { + $self->_resp_text($_); + } + elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) { + $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; + } + elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) { + $cache->{FLAGS} = [ split / /, $1 ]; + } + elsif (/\A([0-9]+) RECENT\z/) { + $cache->{RECENT} = $1; + } + elsif (/\A([0-9]+) EXISTS\z/) { + # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT + if (defined $cache->{EXISTS}) { + $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS}; + # the actual UIDNEXT is *at least* that + $cache->{UIDNEXT} += $1 - $cache->{EXISTS} if defined $cache->{UIDNEXT}; + } + $cache->{EXISTS} = $1; + } + elsif (/\A([0-9]+) EXPUNGE\z/) { + # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs + $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check + $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC'); + $cache->{EXISTS}--; # explicit EXISTS responses are optional + } + elsif (/\ASEARCH((?: [0-9]+)*)\z/) { + $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH'; + } + elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) { + my ($delim, $attrs) = ($2, $1); + my @attrs = defined $attrs ? split(/ /, $attrs) : (); + my $mailbox = $self->_astring(\$_); + $self->panic($_) unless $_ eq ''; + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive + undef $delim if uc $delim eq 'NIL'; + $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim; + $self->_update_cache_for($mailbox, DELIMITER => $delim); + $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs); + $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST'; + } + elsif (s/\ASTATUS //) { + my $mailbox = $self->_astring(\$_); + /\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->_update_cache_for($mailbox, %status); + $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS'; + } + elsif (s/\A([0-9]+) FETCH \(//) { + $self->panic("$1 <= $cache->{EXISTS}") unless $1 <= $cache->{EXISTS}; # sanity check + my ($seq, $first) = ($1, 1); + my %mail; + while ($_ ne ')') { + unless (defined $first) { + s/\A // or $self->panic($_); + } + if (s/\AUID ([0-9]+)//) { + # 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; + } + if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC + # always present in unsolicited FETCH responses if QRESYNC has been enabled + $mail{MODSEQ} = $1; + $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1; + } + elsif (s/\AENVELOPE //) { + $mail{ENVELOPE} = $self->_envelope(\$_); + } + elsif (s/\AINTERNALDATE "([^"]+)"//) { + $mail{INTERNALDATE} = $1; + } + elsif (s/\A(?:RFC822|BODY\[\]) //) { + $mail{RFC822} = $self->_nstring(\$_); + } + elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) { + $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : []; + } + undef $first; + } + + my $uid = $mail{UID} // $self->panic(); # sanity check + $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check + + if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails + (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or + ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) { + 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); + } + elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE + $self->{_ENABLED} //= []; + push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r)); + } + elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC + my $earlier = defined $1 ? 1 : 0; + my $set = $2; + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $pcache = $self->{_PCACHE}->{$mailbox}; + foreach (split /,/, $set) { + 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; + } + 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}}, ($min .. $max); + } + } + } + } + elsif (s/\A\+ //) { + if (defined $callback and $cmd eq 'AUTHENTICATE') { + my $x = $callback->($_); + $self->logger("C: ", $x) if $self->{debug}; + $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!"); + $self->{STDIN}->flush(); + } + } + else { + $self->panic("Unexpected response: ", $_); + } +} + + +############################################################################# + +return 1; diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm deleted file mode 100644 index 6561a66..0000000 --- a/lib/Net/IMAP/Sync.pm +++ /dev/null @@ -1,1617 +0,0 @@ -#---------------------------------------------------------------------- -# A minimal IMAP4 client for QRESYNC-capable servers -# Copyright © 2015 Guilhem Moulin -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#---------------------------------------------------------------------- - -package Net::IMAP::Sync v0.0.1; -use warnings; -use strict; - -use Config::Tiny (); -use IO::Select (); -use List::Util 'first'; -use Socket 'SO_KEEPALIVE'; - -use Exporter 'import'; -BEGIN { - our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/; -} - - -# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'. -my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/; -my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; -my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; - -# Map each option to a regexp validating its values. -my %OPTIONS = ( - host => qr/\A([0-9a-zA-Z:.-]+)\z/, - port => qr/\A([0-9]+)\z/, - 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/, - SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, - 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/, -); - - -############################################################################# -# Utilities - -# read_config($conffile, $sections, %opts) -# Read $conffile's default section, then each section in the array -# reference $section (which takes precedence). %opts extends %OPTIONS -# and maps each option to a regexp validating its values. -sub read_config($$%) { - my $conffile = shift; - my $sections = shift; - my %opts = (%OPTIONS, @_); - - $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile - unless $conffile =~ /\A\//; # relative path - - die "No such config file $conffile\n" - unless defined $conffile and -f $conffile and -r $conffile; - - my $h = Config::Tiny::->read($conffile); - - my %configs; - foreach my $section (@$sections) { - my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section - $configs{$section} = $conf; - - if ($section ne '_') { - die "No such section $section\n" unless defined $h->{$section}; - $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}}; - } - - # default values - $conf->{type} //= 'imaps'; - $conf->{host} //= 'localhost'; - $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef; - $conf->{auth} //= 'PLAIN LOGIN'; - $conf->{STARTTLS} //= 'YES'; - - # untaint and validate the config - foreach my $k (keys %$conf) { - die "Invalid option $k\n" unless defined $opts{$k}; - next unless defined $conf->{$k}; - die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k}; - $conf->{$k} = $1; - } - } - return \%configs; -} - - -# compact_set(@set). -# Compact the UID or sequence number set @set, which must be -# non-empty and may not contain '*'. (Duplicates are allowed, but -# are removed). -sub compact_set(@) { - my @set = sort {$a <=> $b} @_; - my $min = my $max = shift @set // die 'Empty range'; - my $set; - - while (@set) { - my $k = shift @set; - if ($k < $max) { - die "Non-sorted range: $k < $max"; # sanity check - } - elsif ($k == $max) { # skip duplicates - } - elsif ($k == $max + 1) { - $max++; - } - else { - $set .= ',' if defined $set; - $set .= $min == $max ? $min : "$min:$max"; - $min = $max = $k; - } - } - - $set .= ',' if defined $set; - $set .= $min == $max ? $min : "$min:$max"; - return $set; -} - - -# in_set($x, $set) -# Return true if the UID or sequence number $x belongs to the set $set. -# /!\ The highest number in the mailbox, "*" should not appear by -# itself (other than in a range). -sub in_set($$) { - my ($x, $set) = @_; - foreach my $r (split /,/, $set) { - if ($r =~ /\A([0-9]+)\z/) { - return 1 if $x == $1; - } - elsif ($r eq '*' or $r eq '*:*') { - warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)"; - return 1; - } - elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) { - return 1 if $1 <= $x; - } - elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) { - my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1); - return 1 if $min <= $x and $x <= $max; - } - } - return 0; -} - - -# quote($str) -# Quote the given string if needed, or make it a (synchronizing) -# literal. The literals will later be made non-synchronizing if the -# server is LITERAL+-capable (RFC 2088). -sub quote($) { - my $str = shift; - if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) { - return $str; - } - elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) { - $str =~ s/([\x22\x5C])/\\$1/g; - return "\"$str\""; - } - else { - return "{".length($str)."}\r\n".$str; - } -} - - - -############################################################################# -# Public interface -# /!\ While this module can be used with non QRESYNC-capable (or non -# QRESYNC-enabled) servers, there is no internal cache mapping sequence -# numbers to UIDs, so EXPUNGE responses are ignored. - -# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status -# ('OK'/'NO'/'BAD') condition for the last command issued. -our $IMAP_cond; - -# The response text for the last command issued (prefixed with the status -# condition but without the tag). -our $IMAP_text; - - -# Create a new Net::IMAP::Sync object. Connect to the server, -# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and -# update the CAPABILITY list. -# In addition to the %OPTIONS above, valid parameters include: -# -# - 'debug': Enable debug messages. -# -# - 'enable': An extension or array reference of extensions to ENABLE -# (RFC 5161) after entering AUTH state. Croak if the server did not -# advertise "ENABLE" in its CAPABILITY list or does not reply with -# an untagged ENABLED response with all the given extensions. -# -# - 'name': An optional instance name to include in log messages. -# -# - 'extra-attrs': An attribute or list of extra attributes to FETCH -# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE -# BODY.PEEK[]). -# -# - 'logger-fd': An optional filehandle to use for debug output. -# -sub new($%) { - my $class = shift; - my $self = { @_ }; - bless $self, $class; - - # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' - # (cf RFC 3501 section 3) - $self->{_STATE} = ''; - - if ($self->{type} eq 'tunnel') { - require 'IPC/Open2.pm'; - 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 { - my %args = (Proto => 'tcp', Blocking => 1); - $args{PeerHost} = $self->{host} // $self->fail("Missing option host"); - $args{PeerPort} = $self->{port} // $self->fail("Missing option port"); - - my $socket; - if ($self->{type} eq 'imap') { - require 'IO/Socket/INET.pm'; - $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@"); - } - else { - require 'IO/Socket/SSL.pm'; - 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; - $socket = IO::Socket::SSL->new(%args) - or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); - - # ensure we're talking to the right server - $self->_fingerprint_match($socket, $fpr) if defined $fpr; - } - - $socket->sockopt(SO_KEEPALIVE, 1); - $self->{$_} = $socket for qw/STDOUT STDIN/; - } - $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!"); - - # command counter - $self->{_TAG} = 0; - - # internal cache, constantly updated to reflect the current server - # state for each mailbox - $self->{_CACHE} = {}; - - # persistent cache, describing the last clean (synced) state - $self->{_PCACHE} = {}; - - # list of UIDs for which the server a VANISHED or VANISHED (EARLIER) - # response. /!\ requires a QRESYNC-capable server! - # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} - # are considered. - $self->{_VANISHED} = []; - - # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH - # response with the FLAGS attribute. The \Recent flag is always - # omitted from the FLAG list. MODSEQ is always present, and the - # value [ MODSEQ, FLAGS ] is updated if another FETCH response with - # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG - # list of the message is considered unknown and should be retrieved - # manually. - # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} - # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} - # are considered. - $self->{_MODIFIED} = {}; - - if (defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR) { - require 'POSIX.pm'; - require 'Time/HiRes.pm'; - } - - # wait for the greeting - my $x = $self->_getline(); - $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x); - $IMAP_cond = $1; - $IMAP_text = $1.' '.$x; - - # try to update the cache (eg, capabilities) - $self->_resp_text($x); - - if ($IMAP_cond eq 'OK') { - # login required - $self->{_STATE} = 'UNAUTH'; - my @caps = $self->capabilities(); - - 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_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; - IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs) - or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); - - # ensure we're talking to the right server - $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr; - - # refresh the previous CAPABILITY list since the previous one could have been spoofed - delete $self->{_CAPABILITIES}; - @caps = $self->capabilities(); - } - - my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps); - my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef} - split(/ /, $self->{auth}))[0]; - $self->fail("Failed to choose an authentication mechanism") unless defined $mech; - $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and - grep {$_ eq 'LOGINDISABLED'} @caps; - - my ($command, $callback); - my ($username, $password) = @$self{qw/username password/}; - - if ($mech eq 'LOGIN') { - $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; - $command = join ' ', 'LOGIN', quote($username), quote($password); - } - elsif ($mech eq 'PLAIN') { - require 'MIME/Base64.pm'; - $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; - my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); - $command = "AUTHENTICATE $mech"; - if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR - $command .= " $credentials"; - } else { - $callback = sub($) {return $credentials}; - } - } - else { - $self->fail("Unsupported authentication mechanism: $mech"); - } - - delete $self->{password}; # no need to remember passwords - $self->_send($command, $callback); - unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) { - # refresh the CAPABILITY list since the previous one had only pre-login capabilities - delete $self->{_CAPABILITIES}; - $self->capabilities(); - } - } - - $self->{_STATE} = 'AUTH'; - my @extensions = !defined $self->{enable} ? () - : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}} - : ($self->{enable}); - if (@extensions) { - $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("Couldn't ENABLE $_") foreach - grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; - } - - return $self; -} - - -# Log out 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(); - } -} - - -# $self->log($message, [...]) -# $self->logger($message, [...]) -# Log a $message. The latter method is used to log in the 'logger-fd', and -# add timestamps. -sub log($@) { - my $self = shift; - return unless @_; - $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR; - my $prefix = defined $self->{name} ? $self->{name} : ''; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - print STDERR $prefix, ': ', @_, "\n"; -} -sub logger($@) { - my $self = shift; - return unless @_ and defined $self->{'logger-fd'}; - my $prefix = ''; - if ($self->{'logger-fd'}->fileno != fileno STDERR) { - my ($s, $us) = Time::HiRes::gettimeofday(); - $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; - } - $prefix .= defined "$self->{name}" ? $self->{name} : ''; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $self->{'logger-fd'}->say($prefix, ': ', @_); -} - - -# $self->warn($warning, [...]) -# Log a $warning. -sub warn($$@) { - my $self = shift; - $self->log('WARNING: ', @_); -} - - -# $self->fail($error, [...]) -# Log an $error and exit with return value 1. -sub fail($$@) { - my $self = shift; - $self->log('ERROR: ', @_); - exit 1; -} - - -# $self->panic($error, [...]) -# Log a fatal $error including the position of the caller, and exit -# with return value 255. -sub panic($@) { - my $self = shift; - my @loc = caller; - my $msg = "PANIC at line $loc[2] in $loc[1]"; - $msg .= ': ' if @_; - $self->log($msg, @_); - exit 255; -} - - -# $self->capabilities() -# Return the capability list of the IMAP4 server. The list is cached, -# and a CAPABILITY command is only issued if the cache is empty. -sub capabilities($) { - my $self = shift; - $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}}; - $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1'); - return @{$self->{_CAPABILITIES}}; -} - - -# $self->incapable(@capabilities) -# In list context, return the list capabilties from @capabilities -# which were NOT advertised by the server. In scalar context, return -# the length of said list. -sub incapable($@) { - my ($self, @caps) = @_; - my @mycaps = $self->capabilities(); - grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps; -} - - -# $self->search($criterion) -# Issue an UID SEARCH command with the given $criterion. Return the -# list of matching UIDs. -sub search($$) { - my ($self, $crit) = @_; - my @res; - $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_}); - return @res -} - - -# $self->select($mailbox, [$seqs, $UIDs]) -# $self->examine($mailbox, [$seqs, $UIDs]) -# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, -# change the state to SELECTED, otherwise go back to AUTH. -# The optional $seqs and $UIDs are used as Message Sequence Match -# Data for the QRESYNC parameter to the SELECT command. -sub select($$;$$) { - my $self = shift; - my $mailbox = shift; - $self->_select_or_examine('SELECT', $mailbox, @_); -} -sub examine($$;$$) { - my $self = shift; - my $mailbox = shift; - $self->_select_or_examine('EXAMINE', $mailbox, @_); -} - - -# $self->logout() -# Issue a LOGOUT command. Change the state to LOGOUT. -sub logout($) { - my $self = shift; - # don't bother if the connection is already closed - $self->_send('LOGOUT') if $self->{STDIN}->opened(); - $self->{_STATE} = 'LOGOUT'; - undef $self; -} - - -# $self->noop() -# Issue a NOOP command. -sub noop($) { - shift->_send('NOOP'); -} - - -# $self->create($mailbox, [$try]) -# $self->delete($mailbox, [$try]) -# CREATE or DELETE $mailbox. -# If try is set, print a warning but don't crash if the command fails. -sub create($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("CREATE ".quote($mailbox)); - if ($IMAP_cond eq 'OK') { - $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} -sub delete($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("DELETE ".quote($mailbox)); - delete $self->{_CACHE}->{$mailbox}; - delete $self->{_PCACHE}->{$mailbox}; - if ($IMAP_cond eq 'OK') { - $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} - - -# $self->rename($oldname, $newname, [$try]) -# RENAME the mailbox $oldname to $newname. -# If $try is set, print a warning but don't crash if the command fails. -# /!\ Requires a LIST command to be issued to determine the hierarchy -# delimiter and the mailbox attributes for the original name. -sub rename($$$;$) { - my ($self, $from, $to, $try) = @_; - my ($delim, @attrs); - if ($self->{_CACHE}->{$from}) { - $delim = $self->{_CACHE}->{$from}->{DELIMITER}; - @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []}; - } - my $r = $self->_send("RENAME ".quote($from).' '.quote($to)); - $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from}; - $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from}; - if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) { - # on non-flat mailboxes, move children as well (cf 3501) - foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) { - my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r; - $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1}; - $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1}; - } - } - if ($IMAP_cond eq 'OK') { - $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; - } - else { - my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} - - -# $self->subscribe($mailbox, [$try]) -# $self->unsubscribe($mailbox, [$try]) -# SUBSCRIBE or UNSUBSCRIBE $mailbox. -# If $try is set, print a warning but don't crash if the command fails. -sub subscribe($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); - if ($IMAP_cond eq 'OK') { - $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} -sub unsubscribe($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); - if ($IMAP_cond eq 'OK') { - $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} - - -# $self->list($criterion, @parameters) -# Issue a LIST command with the given $criterion and @parameters. -# Return a pair where the first component is a hash reference of -# matching mailboxes and their flags, and the second component is a -# hash reference of matching mailboxes and their hierarchy delimiter -# (or undef for flat mailboxes). -sub list($$@) { - my $self = shift; - my $crit = shift; - my %mailboxes; - my %delims; - $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''), - sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} ); - return (\%mailboxes, \%delims); -} - - -# $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 couldn't be EXPUNGEd. -sub remove_message($@) { - my $self = shift; - my @set = @_; - $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") - if $self->incapable('UIDPLUS'); - - my $set = compact_set(@set); - $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)"); - $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS - - my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; - - my (@failed, @expunged); - foreach my $uid (@set) { - if (exists $vanished{$uid}) { - push @expunged, $uid - } else { - push @failed, $uid; - } - } - - # ignore succesfully EXPUNGEd messages - delete @vanished{@expunged}; - delete @{$self->{_MODIFIED}}{@expunged}; - $self->{_VANISHED} = [ keys %vanished ]; - - $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, $mail, [...]) -# Issue an APPEND command with the given mails. Croak if the server -# 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($$@) { - my $self = shift; - my $mailbox = shift; - return unless @_; - $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") - if $self->incapable('UIDPLUS'); - - my @appends; - foreach my $mail (@_) { - my $append = ''; - $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 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 - my ($UIDNEXT, $EXISTS, $cache, %vanished); - if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { - $cache = $self->{_CACHE}->{$mailbox}; - $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); - $EXISTS = $cache->{EXISTS} // $self->panic(); - %vanished = map {$_ => 1} @{$self->{_VANISHED}}; - } - - $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends)); - $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text); - my ($uidvalidity, $uidset) = ($1, $2); - $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity); - - my @uids; - foreach (split /,/, $uidset) { - if (/\A([0-9]+)\z/) { - $UIDNEXT = $1 + 1 if defined $UIDNEXT and $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 defined $UIDNEXT and $UIDNEXT <= $max; - } else { - $self->panic($_); - } - } - $self->fail("$uidset contains ".scalar(@uids)." elements while " - .scalar(@appends)." messages were appended.") - unless $#uids == $#appends; - - # if $mailbox is the current mailbox we need to update the cache - if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { - # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required - my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}}; - 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} // 1) < $UIDNEXT; - } - - $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) - unless $self->{quiet}; - return @uids; -} - - -# $self->fetch($set, $flags, [$callback]) -# Issue an UID FETCH command with the given UID $set, $flags, and -# optional $callback. -sub fetch($$$$) { - my ($self, $set, $flags, $callback) = @_; - $self->_send("UID FETCH $set $flags", $callback); -} - - -# $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($@) { - my $self = shift; - $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 - # 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'; - $self->_send($command); - $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT}); -} - - -# $self->slurp() -# 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. -# This is mostly useful when waiting for notifications while no -# command is progress, cf. RFC 5465 (NOTIFY). -sub slurp($) { - my $self = shift; - - my $stdout = $self->{STDOUT}; - my $read = 0; - - while (1) { - # Unprocessed data within the current SSL frame would cause - # select(2) to block/timeout due to the raw socket not being - # ready. - unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) { - my ($ok) = $self->{_SEL_OUT}->can_read(0); - return $read unless defined $ok; - } - - $self->_resp( $self->_getline() ); - $read++; - } -} - - -# $self->set_cache( $mailbox, STATE ) -# Initialize or update the persistent cache, that is, associate a -# known $mailbox with the last known (synced) state: -# * UIDVALIDITY -# * UIDNEXT: Any message the UID of which is at least UIDNEXT is -# considered new and must be downloaded. (If 0 or missing, all -# messages in $mailbox are considered new.) Note that while all -# UIDs in the map are panic(); - my $cache = $self->{_PCACHE}->{$mailbox} //= {}; - - my %status = @_; - while (my ($k, $v) = each %status) { - if ($k eq 'UIDVALIDITY') { - # try to detect UIDVALIDITY changes early (before starting the sync) - $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", - "Need to invalidate the UID cache.") - if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; - } - $cache->{$k} = $v; - } - - $self->logger("Update last clean state for $mailbox: ". - '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')') - if $self->{debug}; -} - - -# $self->uidvalidity([$mailbox]) -# Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to -# its UIDVALIDITY if $mailbox is omitted. -sub uidvalidity($;$) { - my $self = shift; - my $mailbox = shift; - if (defined $mailbox) { - my $cache = $self->{_CACHE}->{$mailbox} // return; - return $cache->{UIDVALIDITY}; - } - else { - my %uidvalidity; - while (my ($mbx,$cache) = each %{$self->{_CACHE}}) { - $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0; - } - return %uidvalidity; - } -} - - -# $self->set_cache(@attributes) -# Return the persistent cache for the mailbox currently selected. If -# some @attributes are given, return the list of values corresponding -# to these attributes. -# /!\ Should only be called right after pull_updates! -# Croak if there are unprocessed VANISHED responses or FLAG updates. -sub get_cache($@) { - my $self = shift; - $self->fail("Invalid method 'get_cache' in state $self->{_STATE}") - unless $self->{_STATE} eq 'SELECTED'; - my $mailbox = $self->{_SELECTED} // $self->panic(); - - $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; - $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}}; - - my $cache = $self->{_PCACHE}->{$mailbox}; - return @_ ? @$cache{@_} : %$cache; -} - - -# $self->is_dirty($mailbox) -# Return true if there are pending updates for $mailbox, i.e., its -# internal cache is newer than its persistent cache. -sub is_dirty($$) { - my ($self, $mailbox) = @_; - my $cache = $self->{_CACHE}->{$mailbox} // return 1; - my $pcache = $self->{_PCACHE}->{$mailbox} // return 1; - - if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ} - and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and - defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT} - and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) { - return 0 - } else { - return 1 - } -} - - -# $self->next_dirty_mailbox(@mailboxes) -# Return the name of a dirty mailbox, or undef if all mailboxes are -# clean. If @mailbox is non-empty, only consider mailboxes in that -# list. -sub next_dirty_mailbox($@) { - my $self = shift; - my %mailboxes = map {$_ => 1} @_; - my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) } - keys %{$self->{_CACHE}}; - if ($self->{debug}) { - @dirty ? $self->logger("Dirty mailboxes: ".join(', ', @dirty)) - : $self->logger("Clean state!"); - } - return $dirty[0]; -} - - -# $self->pull_updates([$full]) -# If $full is set, FETCH FLAGS and MODSEQ for each UID up to -# UIDNEXT-1. -# Get pending updates (unprocessed VANISHED responses and FLAG -# updates), and empty these lists from the cache. -# Finally, update the HIGHESTMODSEQ from the persistent cache to the -# value found in the internal cache. -sub pull_updates($;$) { - my $self = shift; - my $full = shift // 0; - my $mailbox = $self->{_SELECTED} // $self->panic(); - my $pcache = $self->{_PCACHE}->{$mailbox}; - - 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 = (); - } - - # 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}; - - # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT - # since there might be new messages) - $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ}); - - return (\@vanished, \%modified); -} - - -# $self->pull_new_messages($callback, @ignore) -# FETCH new messages since the UIDNEXT found in the persistent cache -# (or 1 in no such UIDNEXT is found), and process each response on the -# fly with the callback. -# If an @ignore list is supplied, then these messages are ignored from -# the UID FETCH range. -# Finally, update the UIDNEXT from the persistent cache to the value -# found in the internal cache. -# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ! -sub pull_new_messages($$@) { - my $self = shift; - my $callback = shift; - my @ignore = sort { $a <=> $b } @_; - my @attrs = !defined $self->{'extra-attrs'} ? () - : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}} - : ($self->{'extra-attrs'}); - my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]'; - - my $mailbox = $self->{_SELECTED} // $self->panic(); - - 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++; - } - } - - $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}); -} - - -# $self->push_flag_updates($flags, @set) -# Change the flags to each UID in @set to $flags. -# A flag update fails for mails being updated after the HIGHESTMODSEQ -# found in the persistent cache; push such messages to the MODIFIED -# list. -sub push_flag_updates($$@) { - my $self = shift; - my $flags = shift; - my @set = @_; - - my $mailbox = $self->{_SELECTED} // $self->panic(); - my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic(); - my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; - - my %listed; - $self->_send($command, sub($){ $listed{shift->{UID}}++; }); - - my %failed; - if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { - foreach (split /,/, $1) { - if (/\A([0-9]+)\z/) { - $failed{$1} = 1; - } - elsif (/\A([0-9]+):([0-9]+)\z/) { - my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); - $failed{$_} = 1 foreach ($min .. $max); - } - else { - $self->panic($_); - } - } - } - - my @ok; - foreach my $uid (@set) { - if ($failed{$uid}) { - # $uid was listed in the MODIFIED response code - $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates - delete $self->{_MODIFIED}->{$uid} if - # got a FLAG update for $uid; ignore it if it's $flags - defined $self->{_MODIFIED}->{$uid}->[1] and - $self->{_MODIFIED}->{$uid}->[1] eq $flags; - } - else { - # $uid wasn't listed in the MODIFIED response code - next unless defined $self->{_MODIFIED}->{$uid}; # already stored - $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check - if ($listed{$uid} == 1) { - # ignore succesful update - delete $self->{_MODIFIED}->{$uid}; - } - elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) { - # got multiple FETCH responses for $uid, the last one with $flags - delete $self->{_MODIFIED}->{$uid}; - } - push @ok, $uid; - } - } - - unless ($self->{quiet}) { - $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok; - $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '. - "trying again later") if %failed; - } - return keys %failed; -} - - -############################################################################# -# Private methods - - -# $self->_fingerprint_match($socket, $fingerprint) -# Croak unless the fingerprint of the peer certificate of the -# IO::Socket::SSL object doesn't match the given $fingerprint. -sub _fingerprint_match($$$) { - my ($self, $socket, $fpr) = @_; - - my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256'; - my $fpr2 = $socket->get_fingerprint($algo); - $fpr =~ s/.*\$//; - $fpr2 =~ s/.*\$//; - $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2; -} - - -# $self->_getline([$msg]) -# Read a line from the handle and strip the trailing CRLF. -# /!\ Don't use this method with non-blocking IO! -sub _getline($;$) { - my $self = shift; - my $msg = shift // ''; - - if ($self->{STDOUT}->opened()) { - my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!"); - $x =~ s/\r\n\z// or $self->panic($x); - $self->logger("S: $msg", $x) if $self->{debug}; - return $x; - } - else { - undef $self; - } -} - - -# $self->_update_cache( ATTRIBUTE => VALUE, [...] ) -# Update the internal cache for the currently selected mailbox with -# the given attributes and values. -sub _update_cache($%) { - my $self = shift; - $self->_update_cache_for($self->{_SELECTED}, @_); -} - - -# $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] ) -# Update the internal cache for $mailbox with the given attributes and -# values. -sub _update_cache_for($$%) { - my $self = shift; - my $mailbox = shift // $self->panic(); - my $cache = $self->{_CACHE}->{$mailbox} //= {}; - - my %status = @_; - while (my ($k, $v) = each %status) { - if ($k eq 'UIDVALIDITY') { - # try to detect UIDVALIDITY changes early (before starting the sync) - $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", - "Need to invalidate the UID cache.") - if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; - $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v; - } - $cache->{$k} = $v; - } -} - - -# $self->_send($command, [$callback]) -# Send the given $command to the server, then wait for the response. -# (The status condition and response text are respectively placed in -# $IMAP_cond and $IMAP_text.) Each untagged response received in the -# meantime is read, parsed and processed. The optional $callback, if -# given, is executed with all untagged responses associated with the -# command. -# In void context, croak unless the server answers with a tagged 'OK' -# response. Otherwise, return the condition status ('OK'/'NO'/'BAD'). -sub _send($$;&) { - my ($self, $command, $callback) = @_; - 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; - - # send the command; for servers supporting non-synchronizing - # literals, mark literals as such and then the whole command in one - # go, otherwise send literals one at a time - my $tag = sprintf '%06d', $self->{_TAG}++; - my $litplus; - my @command = ("$tag "); - my $dbg_cmd = "C: $command[0]"; - while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { - my ($str, $len) = ($1, $2); - my $lit = substr $command, 0, $len, ''; # consume the literal - - $litplus //= $self->_capable('LITERAL+') ? '+' : ''; - push @command, $str, "{$len$litplus}", "\r\n"; - $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug}; - $dbg_cmd = 'C: [...]'; - - unless ($litplus) { - $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); - $self->{STDIN}->flush(); - my $x = $self->_getline(); - $x =~ /\A\+ / or $self->panic($x); - @command = (); - } - push @command, $lit; - } - push @command, $command, "\r\n"; - $self->logger($dbg_cmd, $command) if $self->{debug}; - $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); - $self->{STDIN}->flush(); - - - my $r; - # wait for the answer - while (1) { - my $x = $self->_getline(); - if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) { - $IMAP_cond = $1; - $IMAP_text = $1.' '.$x; - $self->_resp_text($x); - $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK'; - $r = $1; - last; - } - else { - $self->_resp($x, $cmd, $set, $callback); - } - } - - if (defined $self->{_SELECTED}) { - my $mailbox = $self->{_SELECTED}; - my $cache = $self->{_CACHE}->{$mailbox}; - # can't keep track of the modification sequences - $self->fail("Mailbox $mailbox doesn't support MODSEQ.") - if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC'); - $self->fail("Mailbox $mailbox does not support persistent UIDs.") - if defined $cache->{UIDNOTSTICKY}; - } - - return $r; -} - - -# $self->_capable($capability, [...]) -# Return true if each $capability is listed in the server's CAPABILITY -# list. -sub _capable($@) { - my $self = shift; - return 0 unless defined $self->{_CAPABILITIES}; - foreach my $cap (@_) { - return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}}; - } - return 1; -} - - -# $self->_capable($extension) -# Return true if $extension has been enabled by the server, i.e., the -# server sent an untagged ENABLED response including it. -sub _enabled($$) { - my $self = shift; - my $ext = uc shift; - grep {$ext eq uc $_} @{$self->{_ENABLED} // []}; -} - - -# $self->_open_mailbox($mailbox) -# Initialize the internal and persistent caches for $mailbox, and mark -# it as selected. -sub _open_mailbox($$) { - my $self = shift; - my $mailbox = shift; - - # it is safe to wipe cached VANISHED responses or FLAG updates, - # because interesting stuff must have made the mailbox dirty so - # we'll get back to it - $self->{_VANISHED} = []; - $self->{_MODIFIED} = {}; - - $self->{_SELECTED} = $mailbox; - $self->{_CACHE}->{$mailbox} //= {}; - - # always reset EXISTS to keep track of new mails - delete $self->{_CACHE}->{$mailbox}->{EXISTS}; -} - - -# $self->_select_or_examine($command, $mailbox, [$seqs, $UIDs]) -# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, -# change the state to SELECTED, otherwise go back to AUTH. -# The optional $seqs and $UIDs are used as Message Sequence Match -# Data for the QRESYNC parameter to the $command. -sub _select_or_examine($$$;$$) { - my $self = shift; - my $command = shift; - my $mailbox = shift; - my ($seqs, $uids) = @_; - - my $pcache = $self->{_PCACHE}->{$mailbox} //= {}; - my $cache = $self->{_CACHE}->{$mailbox} //= {}; - $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY}; - - $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive - $command .= ' '.quote($mailbox); - if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) { - $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " - ."1:".($pcache->{UIDNEXT}-1); - $command .= " ($seqs $uids)" if defined $seqs and defined $uids; - $command .= "))"; - } - - if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { - # 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 - # previous mailbox ($self->{_SELECTED}), while all subsequent - # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. - $self->{_SELECTED_DELAYED} = $mailbox; - } - else { - $self->_open_mailbox($mailbox); - } - - $self->{_STATE} = 'AUTH'; - $self->_send($command); - $self->{_STATE} = 'SELECTED'; -} - - - -############################################################################# -# Parsing methods -# - -# Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed. -sub _resp_text($$) { - my $self = shift; - local $_ = shift; - - if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) { - $self->log($_); - } - elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) { - $self->fail($_); - } - elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) { - $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; - } - elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) { - $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] ); - } - elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) { - $self->_update_cache($1 => 1); - } - elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) { - $self->_update_cache($1 => $2); - } - elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) { - # RFC 4551/7162 CONDSTORE/QRESYNC - $self->_update_cache(HIGHESTMODSEQ => $1); - } - elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) { - # RFC 4551/7162 CONDSTORE/QRESYNC - $self->_update_cache(NOMODSEQ => 1); - } - elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) { - # RFC 7162 CONDSTORE/QRESYNC - # Update the selected mailbox: previous responses refer to the - # previous mailbox ($self->{_SELECTED}), while all subsequent - # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. - my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic(); - $self->_open_mailbox($mailbox); - } - elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) { - # RFC 5465 NOTIFY - $self->fail($_); - } - elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) { - # RFC 4315 UIDPLUS - $self->_update_cache(UIDNOTSTICKY => 1); - } -} - -# Parse and consume an RFC 3501 nstring (string / "NIL"). -sub _nstring($$) { - my ($self, $stream) = @_; - return $$stream =~ s/\ANIL// ? undef : $self->_string($stream); -} - -# Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string). -sub _astring($$) { - my ($self, $stream) = @_; - return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream); -} - -# Parse and consume an RFC 3501 string (quoted / literal). -sub _string($$) { - my ($self, $stream) = @_; - if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) { - # quoted - my $str = $1; - $str =~ s/\\([\x22\x5C])/$1/g; - return $str; - } - elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) { - # literal - $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!"); - # read a the rest of the response - $$stream = $self->_getline('[...]'); - return $lit; - } - else { - $self->panic($$stream); - } -} - -# Parse and consume an RFC 3501 "(" 1*address ")" / "NIL". -sub _addresses($$) { - my ($self, $stream) = @_; - return undef if $$stream =~ s/\ANIL//; - - my @addresses; - $$stream =~ s/\A\(// or $self->panic($$stream); - while ($$stream =~ s/\A ?\(//) { - my @addr; - push @addr, $self->_nstring($stream); # addr-name - $$stream =~ s/\A // or $self->panic($$stream); - push @addr, $self->_nstring($stream); # addr-adl - $$stream =~ s/\A // or $self->panic($$stream); - push @addr, $self->_nstring($stream); # addr-mailbox - $$stream =~ s/\A // or $self->panic($$stream); - push @addr, $self->_nstring($stream); # addr-host - $$stream =~ s/\A\)// or $self->panic($$stream); - push @addresses, \@addr; - } - $$stream =~ s/\A\)// or $self->panic($$stream); - return \@addresses; -} - -# Parse and consume an RFC 3501 envelope -sub _envelope($$) { - my ($self, $stream) = @_; - $$stream =~ s/\A\(// or $self->panic($$stream); - - my @envelope; - push @envelope, $self->_nstring($stream); # env-date - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_nstring($stream); # env-subject - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_addresses($stream); # env-from - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_addresses($stream); # env-sender - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_addresses($stream); # env-reply-to - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_addresses($stream); # env-to - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_addresses($stream); # env-cc - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_addresses($stream); # env-bcc - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_nstring($stream); # env-in-reply-to - $$stream =~ s/\A // or $self->panic($$stream); - push @envelope, $self->_nstring($stream); # env-message-id - - $$stream =~ s/\A\)// or $self->panic($$stream); - return \@envelope; -} - -# $self->_resp($buf, [$cmd, $callback] ) -# Parse an untagged response line or a continuation request line. -# (The trailing CRLF must be removed.) The internal cache is -# automatically updated when needed. -# If a command and callback are given, the callback is be executed -# for each (parsed) responses associated with the command. -sub _resp($$;$$$) { - my $self = shift; - local $_ = shift; - my $cmd = shift; - my $set = shift; - my $callback = shift; - my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED}; - - if (s/\A\* //) { - if (s/\ABYE //) { - undef $self; - } - elsif (s/\A(?:OK|NO|BAD) //) { - $self->_resp_text($_); - } - elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) { - $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; - } - elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) { - $cache->{FLAGS} = [ split / /, $1 ]; - } - elsif (/\A([0-9]+) RECENT\z/) { - $cache->{RECENT} = $1; - } - elsif (/\A([0-9]+) EXISTS\z/) { - # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT - if (defined $cache->{EXISTS}) { - $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS}; - # the actual UIDNEXT is *at least* that - $cache->{UIDNEXT} += $1 - $cache->{EXISTS} if defined $cache->{UIDNEXT}; - } - $cache->{EXISTS} = $1; - } - elsif (/\A([0-9]+) EXPUNGE\z/) { - # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs - $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check - $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC'); - $cache->{EXISTS}--; # explicit EXISTS responses are optional - } - elsif (/\ASEARCH((?: [0-9]+)*)\z/) { - $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH'; - } - elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) { - my ($delim, $attrs) = ($2, $1); - my @attrs = defined $attrs ? split(/ /, $attrs) : (); - my $mailbox = $self->_astring(\$_); - $self->panic($_) unless $_ eq ''; - $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive - undef $delim if uc $delim eq 'NIL'; - $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim; - $self->_update_cache_for($mailbox, DELIMITER => $delim); - $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs); - $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST'; - } - elsif (s/\ASTATUS //) { - my $mailbox = $self->_astring(\$_); - /\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->_update_cache_for($mailbox, %status); - $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS'; - } - elsif (s/\A([0-9]+) FETCH \(//) { - $self->panic("$1 <= $cache->{EXISTS}") unless $1 <= $cache->{EXISTS}; # sanity check - my ($seq, $first) = ($1, 1); - my %mail; - while ($_ ne ')') { - unless (defined $first) { - s/\A // or $self->panic($_); - } - if (s/\AUID ([0-9]+)//) { - # 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; - } - if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC - # always present in unsolicited FETCH responses if QRESYNC has been enabled - $mail{MODSEQ} = $1; - $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1; - } - elsif (s/\AENVELOPE //) { - $mail{ENVELOPE} = $self->_envelope(\$_); - } - elsif (s/\AINTERNALDATE "([^"]+)"//) { - $mail{INTERNALDATE} = $1; - } - elsif (s/\A(?:RFC822|BODY\[\]) //) { - $mail{RFC822} = $self->_nstring(\$_); - } - elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) { - $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : []; - } - undef $first; - } - - my $uid = $mail{UID} // $self->panic(); # sanity check - $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check - - if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails - (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or - ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) { - 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); - } - elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE - $self->{_ENABLED} //= []; - push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r)); - } - elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC - my $earlier = defined $1 ? 1 : 0; - my $set = $2; - my $mailbox = $self->{_SELECTED} // $self->panic(); - my $pcache = $self->{_PCACHE}->{$mailbox}; - foreach (split /,/, $set) { - 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; - } - 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}}, ($min .. $max); - } - } - } - } - elsif (s/\A\+ //) { - if (defined $callback and $cmd eq 'AUTHENTICATE') { - my $x = $callback->($_); - $self->logger("C: ", $x) if $self->{debug}; - $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!"); - $self->{STDIN}->flush(); - } - } - else { - $self->panic("Unexpected response: ", $_); - } -} - - -############################################################################# - -return 1;