From dbfa9158ead98ed37a1f1d10e4d1d07ae46013a0 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Sep 2015 15:16:33 +0200 Subject: Add instruction for how to build a Debian package from the last release. --- INSTALL | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/INSTALL b/INSTALL index 3c581cb..7cfbdc3 100644 --- a/INSTALL +++ b/INSTALL @@ -22,6 +22,11 @@ following command: However Debian GNU/Linux users can also use gbp(1) from git-buildpackage to build their own package: + $ git checkout debian + $ AUTO_DEBSIGN=no gbp buildpackage + +Alternatively, for the development version: + $ git checkout debian $ git merge master $ AUTO_DEBSIGN=no gbp buildpackage --git-force-create --git-upstream-tree=BRANCH -- cgit v1.2.3 From adf204a2b54eb5fc47e97042012be0e407ac7e42 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Sep 2015 15:49:21 +0200 Subject: Add a note imapsync vs. offlineimap. --- README | 49 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 12 deletions(-) diff --git a/README b/README index 4192812..1195720 100644 --- a/README +++ b/README @@ -1,17 +1,34 @@ -imapsync 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 imapsync 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. +imapsync is a fast bidirectional synchronization program for +QRESYNC-capable IMAP servers. Consult the manual for more information. -Consult the manual for more information. -imapsync 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. +####################################################################### + + +Compared to IMAP-to-Maildir synchronization solutions like OfflineIMAP, +adding an IMAP server between the Maildir storage and the MUA saves +loads of readdir(2) system calls and other File System quirks; moreover +the abstraction layer offered by the IMAP server makes the MUA and +synchronization program agnostic to the storage backend (Maildir, mbox, +dbox,...) in use. + +IMAP synchronization of a mailbox is usually two-folds: 1/ detect and +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 +[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+ +[RFC2088] and MULTIAPPEND [RFC3502], these extensions greatly improve +performance by reducing the number of required round trips hence are +recommended. + ####################################################################### @@ -53,3 +70,11 @@ type=imaps. 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 + + +####################################################################### + + +imapsync 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. -- cgit v1.2.3 From ac3e4cf6300448e9c83b45db1b769d79c6df2e38 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Sep 2015 17:36:00 +0200 Subject: =?UTF-8?q?Rename=20=E2=80=98imapsync=E2=80=99=20to=20=E2=80=98int?= =?UTF-8?q?erimap=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit To avoid confusion with http://imapsync.lamiral.info . --- Changelog | 6 +- INSTALL | 2 +- README | 16 +- imapsync | 1197 --------------------------------- imapsync.1 | 333 ---------- imapsync.sample | 23 - imapsync.service | 12 - interimap | 1197 +++++++++++++++++++++++++++++++++ interimap.1 | 334 ++++++++++ interimap.sample | 23 + interimap.service | 12 + lib/Net/IMAP/InterIMAP.pm | 1617 +++++++++++++++++++++++++++++++++++++++++++++ lib/Net/IMAP/Sync.pm | 1617 --------------------------------------------- 13 files changed, 3195 insertions(+), 3194 deletions(-) delete mode 100755 imapsync delete mode 100644 imapsync.1 delete mode 100644 imapsync.sample delete mode 100644 imapsync.service create mode 100755 interimap create mode 100644 interimap.1 create mode 100644 interimap.sample create mode 100644 interimap.service create mode 100644 lib/Net/IMAP/InterIMAP.pm delete mode 100644 lib/Net/IMAP/Sync.pm 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; -- cgit v1.2.3