diff options
| -rw-r--r-- | Changelog | 5 | ||||
| -rwxr-xr-x | imapsync | 796 | ||||
| -rw-r--r-- | lib/Net/IMAP/Sync.pm | 1495 |
3 files changed, 2296 insertions, 0 deletions
diff --git a/Changelog b/Changelog new file mode 100644 index 0000000..4c3a493 --- /dev/null +++ b/Changelog @@ -0,0 +1,5 @@ +imapsync (0.1) upstream; + + * Initial release. + + -- Guilhem Moulin <guilhem@guilhem.org> Thu, 23 Jul 2015 04:15:47 +0200 diff --git a/imapsync b/imapsync new file mode 100755 index 0000000..eb8f652 --- /dev/null +++ b/imapsync @@ -0,0 +1,796 @@ +#!/usr/bin/perl -T + +#---------------------------------------------------------------------- +# A minimal IMAP4 client for QRESYNC-capable servers +# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org> +# +# 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 <http://www.gnu.org/licenses/>. +#---------------------------------------------------------------------- + +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 List::Util 'first'; +use DBI (); +use POSIX 'strftime'; + +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; + print STDERR "TODO $NAME usage\n"; + exit $rv; +} +usage(1) unless GetOptions(\%CONFIG, qw/debug help|h quiet|q oneshot|1/); +usage(0) if $CONFIG{help}; + + +my $CONFFILE = 'sync.ini'; +my $CACHEDIR = './imapsync.cache'; # XXX use a config option +my $DBFILE = "$CACHEDIR/imap.guilhem.org.db"; +my $LOCKFILE = "$CACHEDIR/.imap.guilhem.org.lck"; +my ($DBH, $IMAP); + + +# Clean after us +sub clean() { + print STDERR "Cleaning...\n" if $CONFIG{debug}; + unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE; + undef $_ foreach grep defined, map {$IMAP->{$_}->{client}} keys %$IMAP; + $DBH->disconnect() if defined $DBH; +} +$SIG{$_} = sub { clean(); die "$!\n"; } foreach qw/INT TERM/; + + +############################################################################# +# Lock the database +{ + if (!-d $CACHEDIR) { + mkdir $CACHEDIR, 0700 or die "Cannot mkdir $CACHEDIR: $!\n"; + } + elsif (-f $LOCKFILE) { + open my $lock, '<', $LOCKFILE or die "Cannot 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 "Cannot 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 CHECK (UIDNEXT > 0)}, + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)} + # one-to-one correspondence between local.idx and remote.idx + ], + remote => [ + q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)}, + q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)}, + q{UIDNEXT UNSIGNED INT NOT NULL CHECK (UIDNEXT > 0)}, + q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)} + # 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 + # 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 @_; + my $prefix = strftime "%b %e %H:%M:%S", localtime; + $prefix .= " $name" if defined $name; + $prefix .= ': '; + print STDERR $prefix, @_, "\n"; +} + + +############################################################################# +# Connect to the local and remote IMAP servers + +foreach my $name (qw/local remote/) { + my %config = Net::IMAP::Sync::read_config($CONFFILE, $name); + $config{$_} = $CONFIG{$_} foreach keys %CONFIG; + $config{enable} = 'QRESYNC'; + $config{name} = $name; + + $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).')'); + $client->notify(qw/SELECTED SUBSCRIBED/) unless $CONFIG{oneshot}; + # 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 + @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list(q{"" "*"}, 'SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)' ); +} + + +############################################################################# +# Synchronize mailbox and subscription lists + +sub make_tree(%); +sub print_tree($%); +sub mv_tree($$$%); +sub sync_tree($$%); + +# Take a hash of delimiters, and recursively build a tree out of it. +# For instance ( a => "/", b => "/", "a/c" => ".", "a/c.d" => "/", "a/d" => ".") +# is transformed into the hash reference +# { b => {}, +# { a => { "/c" => { ".d" => {} } } +# , "/d" => {} +# } +# } +sub make_tree(%) { + my %delims = @_; + my @list = sort {length($a) <=> length($b)} keys %delims; + + my %tree; + foreach my $x (@list) { + next unless exists $delims{$x}; # already a children of something + my %children; + foreach (keys %delims) { + next unless defined $delims{$x} and s/\A\Q$x$delims{$x}\E/$delims{$x}/; + $children{$_} = delete $delims{"$x$_"}; + } + delete $delims{$x}; + $tree{$x} = make_tree(%children); + } + return \%tree; +} +#sub print_tree($%) { +# my $indent = shift; +# my %tree = @_; +# while (my ($root, $children) = each %tree) { +# print " "x$indent, '|- ', $root, "\n"; +# print_tree($indent+2, %$children); +# } +#} + +# Retrun true if $mailbox exists for $name that is, if doesn't have the +# '\NonExistent' flag set. +sub exists_mbx($$) { + my $name = shift; + my $mailbox = shift; + my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $flags and !grep {lc $_ eq lc '\NonExistent'} @$flags) ? 1 : 0; +} +# Retrun true if $mailbox is subscribed for $name. +sub subscribed_mbx($$) { + my $name = shift; + my $mailbox = shift; + my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $flags and grep {lc $_ eq lc '\Subscribed'} @$flags) ? 1 : 0; +} + +# Rename a root recursively in a tree +sub mv_tree($$$%) { + my ($mailboxes, $mbx, $mbx2, %children) = @_; + $mailboxes->{$mbx2} = delete $mailboxes->{$mbx}; + while (my ($root, $children) = each %children) { + mv_tree($mailboxes, $mbx.$root, $mbx2.$root, %children); + } +} + +# Syncronize mailbox list +# XXX DELETE and RENAME not tested +sub sync_tree($$%) { + my ($sth, $mbx, %children) = @_; + my %exists = map { $_ => exists_mbx($_,$mbx) } qw/local remote/; + + my $rv = 0; + if ($exists{local} xor $exists{remote}) { + my ($exists,$missing) = $exists{local} ? ('local','remote') : ('remote','local'); + my ($sth_by_mbx, $sth_by_uidvalidity) = @$sth{($missing.'_by_mbx', $exists.'_by_uidvalidity')}; + + # check if there is an entry matching $mbx for $missing in the database + $sth_by_mbx->execute($mbx); + my $row_by_mbx = $sth_by_mbx->fetch(); + die if defined $sth_by_mbx->fetch(); # sanity check + + if (defined $row_by_mbx) { + # $mbx was seen on $missing during the previous round: it + # has either been DELETEd or RENAMEd to another name on + # $missing. + + my %uidvalidities = $IMAP->{$missing}->{client}->uidvalidity(); + my ($idx,$uidvalidity) = @$row_by_mbx; + my @mbx2 = grep { $uidvalidities{$_} == $uidvalidity and !exists_mbx($exists,$_) } + keys %uidvalidities; + + if ($#mbx2 > 0) { + # XXX this is allowed by RFC3501, but we can't guess... + msg($missing, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ", + join(',',@mbx2), "\n", + "Dunno which one $mbx should be renamed to."); + exit 1; + } + elsif (@mbx2) { + # $mbx's known (from the DB) UIDVALIDITY is that of + # $missing's $mbx2, which is not in the database and + # doesn't exist on $exists + msg($exists, "Rename mailbox $mbx to $mbx2[0]"); + $sth->{rename}->execute($mbx2[0],$idx); + $IMAP->{$exists}->{client}->rename($mbx, $mbx2[0]); + $DBH->commit(); + mv_tree($IMAP->{$exists}->{mailboxes}, $mbx, $mbx2[0], %children); + $mbx = $mbx2[0]; + } + else { + # $mbx's known (from the DB) UIDVALIDITY on $missing + # was not found in any of $missing's mailboxes. + msg($exists, "Delete mailbox $mbx"); + push @{$IMAP->{$exists}->{mailboxes}->{$mbx}}, '\NonExistent'; + $IMAP->{$exists}->{client}->delete($mbx); + } + } + else { + # $mbx was never seen on $missing: it has either been + # CREATEd or RENAMEd from another name on $exists. + + my ($idx,$mbx2); + if (defined (my $uidvalidity = $IMAP->{$exists}->{client}->uidvalidity($mbx))) { + $sth_by_uidvalidity->execute($uidvalidity); + my $by_uidvalidity = $sth_by_uidvalidity->fetchall_arrayref(); + if (defined $by_uidvalidity and $#$by_uidvalidity > 0) { + # XXX this is allowed by RFC3501, but we can't guess... + my @mbx2 = map {$_->[1]} @$by_uidvalidity; + msg($exists, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ", + join(',',@mbx2), "\n", + "Dunno which one $mbx should be renamed to."); + exit 1; + } + ($idx,$mbx2) = @{$by_uidvalidity->[0]} if defined $by_uidvalidity and @$by_uidvalidity; + } + + if (defined $mbx2) { + # $mbx's UIDVALIDITY on $exists can be found in the + # database as associated with $mbx2, which exists on + # $missing but not on $exists + msg($missing, "Rename mailbox $mbx2 to $mbx"); + $sth->{rename}->execute($mbx,$idx); + $IMAP->{$missing}->{client}->rename($mbx2, $mbx); + $DBH->commit(); + mv_tree($IMAP->{$missing}->{mailboxes}, $mbx2, $mbx, %children); + } + else { + # $mbx's UIDVALIDITY on $exists has never been found in + # the database. + msg($missing, "Create mailbox $mbx"); + $IMAP->{$missing}->{mailboxes}->{$mbx} = + grep {lc $_ ne lc '\NonExistent'} @{$IMAP->{$missing}->{mailboxes}->{$mbx} // []}; + $IMAP->{$missing}->{client}->create($mbx); + } + } + $rv = 1; + } + + while (my ($root, $children) = each %children) { + my $r = sync_tree($sth, $mbx.$root, %$children); + $rv ||= $r; + } + return $rv; +} + +{ + my %delims; + foreach my $name (qw/local remote/) { + while (my ($mbx, $sep) = each %{$IMAP->{$name}->{delims}}) { + if (!exists $delims{$mbx}) { + $delims{$mbx} = $sep; + } else { + die "Hierarchy delimeters for mailbox $mbx don't match!\n" + unless (!defined $sep and !defined $delims{$mbx}) or + (defined $sep and defined $delims{$mbx} and $sep eq $delims{$mbx}); + } + } + } + + my $tree = make_tree(%delims); + my %sth; + $sth{$_.'_by_mbx'} = $DBH->prepare("SELECT idx,UIDVALIDITY FROM mailboxes NATURAL JOIN $_ WHERE mailbox = ?") + foreach qw/local remote/; + $sth{$_.'_by_uidvalidity'} = $DBH->prepare("SELECT idx,mailbox FROM mailboxes NATURAL JOIN $_ WHERE UIDVALIDITY = ?") + foreach qw/local remote/; + $sth{rename} = $DBH->prepare("UPDATE mailboxes SET mailbox = ? WHERE idx = ?"); + + my $updated = 0; + while (my ($mbx,$children) = each %$tree) { + #print $mbx, "\n"; + #print_tree(0, %$children); + my $u = sync_tree(\%sth, $mbx, %$children); + $updated ||= $u; + } + + if ($updated) { + # refresh the mailbox list + foreach my $name (qw/local remote/) { + @{$IMAP->{$name}}{qw/mailboxes delims/} = $IMAP->{$name}->{client}->list(q{"" "*"}, 'SUBSCRIBED'); + } + my %mailboxes; + $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}}); + foreach my $mbx (keys %mailboxes) { + die "Could not sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx); + } + } +} + +# Syncronize subscription list +my @SUBSCRIPTIONS; +{ + my $sth_search = $DBH->prepare("SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?"); + my $sth_subscribe = $DBH->prepare("UPDATE mailboxes SET subscribed = ? WHERE idx = ?"); + + my %mailboxes; + $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}}); + + foreach my $mbx (keys %mailboxes) { + if (subscribed_mbx('local',$mbx) xor subscribed_mbx('remote',$mbx)) { + my ($subscribed,$unsubscribed) = subscribed_mbx('local',$mbx) ? ('local','remote') : ('remote','local'); + + $sth_search->execute($mbx); + my $row = $sth_search->fetch(); + die if defined $sth_search->fetch(); # sanity check + + if (defined $row) { + my ($idx,$status) = @$row; + if ($status) { + # $mbx was SUBSCRIBEd before, UNSUBSCRIBE it now + msg($subscribed, "Unsubscribe to mailbox $mbx"); + $sth_subscribe->execute(0,$idx); + $IMAP->{$subscribed}->{client}->unsubscribe($mbx); + $DBH->commit(); + $IMAP->{$subscribed}->{mailboxes}->{$mbx} = + grep {lc $_ ne lc '\Subscribed'} @{$IMAP->{$subscribed}->{mailboxes}->{$mbx} // []}; + } + else { + # $mbx was UNSUBSCRIBEd before, SUBSCRIBE it now + msg($unsubscribed, "Subscribe to mailbox $mbx"); + $sth_subscribe->execute(1,$idx); + $IMAP->{$unsubscribed}->{client}->subscribe($mbx); + $DBH->commit(); + $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= []; + push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed'; + } + } + else { + # $mbx is unknown; assume the user wants to SUBSCRIBE + msg($unsubscribed, "Subscribe to mailbox $mbx"); + $IMAP->{$unsubscribed}->{client}->subscribe($mbx); + $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= []; + push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed'; + } + } + push @SUBSCRIPTIONS, $mbx if subscribed_mbx('local', $mbx) and + subscribed_mbx('remote',$mbx); + } +} + +# Clean database: remove mailboxes that no longer exist +{ + my $sth = $DBH->prepare("SELECT idx,mailbox,subscribed FROM mailboxes"); + my $sth_delete_mailboxes = $DBH->prepare("DELETE FROM mailboxes WHERE idx = ?"); + my $sth_delete_local = $DBH->prepare("DELETE FROM local WHERE idx = ?"); + my $sth_delete_remote = $DBH->prepare("DELETE FROM remote WHERE idx = ?"); + my $sth_delete_mapping = $DBH->prepare("DELETE FROM mapping WHERE idx = ?"); + + my @idx; + $sth->execute(); + while (defined (my $row = $sth->fetch)) { + my ($idx,$mbx,$subscribed) = @$row; + if (!exists_mbx('local',$mbx) and !exists_mbx('remote',$mbx)) { + $_->execute($idx) foreach ($sth_delete_mapping,$sth_delete_local,$sth_delete_remote); + $sth_delete_mailboxes->execute($idx) if + !exists $IMAP->{local}->{mailboxes}->{$mbx} and + !exists $IMAP->{remote}->{mailboxes}->{$mbx}; + $DBH->commit(); + } + } +} + + + +############################################################################# +# Synchronize messages +# Consider only the mailboxes in @ARGV, if the list is non-empty. + +my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/; +undef $IMAP; + + +# Get all cached states from the database. +my $STH_GET_CACHE = $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 +}); + +# Get the index associated with a mailbox. +my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx FROM mailboxes WHERE mailbox = ?}); + +# Find local/remote UID from the map. +my $STH_GET_LOCAL_UID = $DBH->prepare("SELECT lUID FROM mapping WHERE idx = ? and rUID = ?"); +my $STH_GET_REMOTE_UID = $DBH->prepare("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("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_NEWMAILBOX = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); +my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)}); +my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)}); + +# Insert a (idx,lUID,rUID) association. +my $STH_INSERT_MAPPING = $DBH->prepare("INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)"); + + +# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness. +$STH_GET_CACHE->execute(); +while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { + $lIMAP->set_cache($row->{mailbox}, + UIDVALIDITY => $row->{lUIDVALIDITY}, + UIDNEXT => $row->{lUIDNEXT}, + HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ} + ); + $rIMAP->set_cache($row->{mailbox}, + UIDVALIDITY => $row->{rUIDVALIDITY}, + UIDNEXT => $row->{rUIDNEXT}, + HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ} + ); +} + + +# 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 = shift; + my $update = 0; + + # loop since processing might produce VANISHED or unsollicited FETCH responses + while (1) { + my ($lVanished, $lModified) = $lIMAP->pull_updates(); + my ($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); + 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) { + warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n"; + } + 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) { + warn "WARNING: Couldn't find a matching lUID for (idx,rUID) = ($idx,$rUID)\n"; + } + elsif (!exists $lVanished{$lUID}) { + push @lToRemove, $lUID; + } + } + + $lIMAP->remove(@lToRemove) if @lToRemove; + $rIMAP->remove(@rToRemove) if @rToRemove; + + # remove existing mappings + foreach my $lUID (@$lVanished, @lToRemove) { + my $r = $STH_DELETE_MAPPING->execute($idx, $lUID); + die if $r > 1; # sanity check + warn "WARNING: Couldn't delete (idx,lUID) pair ($idx,$lUID)\n" if $r == 0; + } + } + + # 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) { + warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n"; + } + elsif (defined (my $rFlags = $rModified->{$rUID})) { + unless ($lFlags eq $rFlags) { + my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags)); + my $flags = join ' ', sort(keys %flags); + warn "WARNING: Conflicting FLAG update for lUID $lUID ($lFlags) and". + "rUID $rUID ($rFlags). Setting both to the union ($flags).\n"; + $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) { + warn "WARNING: Couldn't find a matching rUID for (idx,rUID) = ($idx,$rUID)\n"; + } + 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); + } + } + } +} + + +# Sync known and new messages +sub sync_messages($$) { + my ($idx, $mailbox) = @_; + + my %mapping; + foreach my $source (qw/remote local/) { + my $target = $source eq 'local' ? $rIMAP : $lIMAP; + my $multiappend; + + my @newmails; + my $buffer = 0; # sum of the RFC822 sizes in @newmails + + my (@sUID, @tUID); + + # don't fetch again the messages we've just added + my @ignore = $source eq 'local' ? keys %mapping : values %mapping; + + ($source eq 'local' ? $lIMAP : $rIMAP)->pull_new_messages(sub(%) { + my %mail = @_; + return unless exists $mail{RFC822}; # not for us + + my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE}); + push @sUID, $mail{UID}; + + # use MULTIAPPEND if possible (RFC 3502) to save round-trips + $multiappend //= !$target->incapable('MULTIAPPEND'); + + if (!$multiappend) { + my ($uid) = $target->append($mailbox, @mail); + push @tUID, $uid; + } + else { + # proceed by batch of 1MB to save roundtrips without blowing up the memory + if (@newmails and $buffer + length($mail{RFC822}) > 1048576) { + push @tUID, $target->append($mailbox, @newmails); + @newmails = (); + $buffer = 0; + } + push @newmails, @mail; + $buffer += length $mail{RFC822}; + } + }, @ignore); + push @tUID, $target->append($mailbox, @newmails) if @newmails; + + die unless $#sUID == $#tUID; # sanity check + foreach my $k (0 .. $#sUID) { + my ($lUID,$rUID) = $source eq 'local' ? ($sUID[$k],$tUID[$k]) : ($tUID[$k],$sUID[$k]); + die if exists $mapping{$lUID}; # sanity check + $mapping{$lUID} = $rUID; + } + } + + # new mailbox + if (!defined $$idx) { + my $subscribed = grep { $_ eq $mailbox} @SUBSCRIPTIONS ? 1 : 0; + $STH_NEWMAILBOX->execute($mailbox, $subscribed); + $STH_GET_INDEX->execute($mailbox); + ($$idx) = $STH_GET_INDEX->fetchrow_array(); + die if !defined $$idx or defined $STH_GET_INDEX->fetchrow_arrayref(); # sanity check + + # there might be flag updates pending + sync_known_messages($$idx); + $STH_INSERT_LOCAL->execute($$idx, $lIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/)); + $STH_INSERT_REMOTE->execute($$idx, $rIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/)); + } + else { + # update known mailbox + sync_known_messages($$idx); + $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $$idx); + $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $$idx); + } + + while (my ($lUID,$rUID) = each %mapping) { + $STH_INSERT_MAPPING->execute($$idx, $lUID, $rUID); + } + $DBH->commit(); +} + + + +# Wait for notifications on either IMAP server, up to $timout. 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(); + } + } +} + + +my ($mailbox, $idx); +while(1) { + while(1) { + my $cache; + my $update = 0; + if (defined $mailbox and ($lIMAP->is_dirty($mailbox) or $rIMAP->is_dirty($mailbox))) { + # $mailbox is dirty on either the local or remote mailbox + sync_messages(\$idx, $mailbox); + } + else { + $mailbox = $lIMAP->next_dirty_mailbox(@ARGV) // $rIMAP->next_dirty_mailbox(@ARGV) // last; + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case insensitive + + $STH_GET_INDEX->execute($mailbox); + ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + $lIMAP->select($mailbox); + $rIMAP->select($mailbox); + + # sync updates to known messages before fetching new messages + if (defined $idx and sync_known_messages($idx)) { + # get_cache is safe after pull_update + $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $idx); + $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $idx); + $DBH->commit(); + } + sync_messages(\$idx, $mailbox); + } + } + # clean state! + exit 0 if $CONFIG{oneshot}; + wait_notifications(900); +} + +END { clean (); } diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm new file mode 100644 index 0000000..b952546 --- /dev/null +++ b/lib/Net/IMAP/Sync.pm @@ -0,0 +1,1495 @@ +#---------------------------------------------------------------------- +# A minimal IMAP4 client for QRESYNC-capable servers +# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org> +# +# 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 <http://www.gnu.org/licenses/>. +#---------------------------------------------------------------------- + +package Net::IMAP::Sync v0.0.1; +use warnings; +use strict; + +use Config::Tiny (); +use List::Util 'first'; +use Socket 'SO_KEEPALIVE'; +use POSIX 'strftime'; + +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?|preauth)\z/, + STARTTLS => qr/\A(true|false)\z/i, + username => qr/\A([\x01-\x7F]+)\z/, + password => qr/\A([\x01-\x7F]+)\z/, + auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, + command => qr/\A(\P{Control}+)\z/, + 'read-only' => qr/\A(TRUE|FALSE)\z/i, + SSL_ca_path => qr/\A(\P{Control}+)\z/, + SSL_cipher_list => qr/\A(\P{Control}+)\z/, + SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, +); + + +############################################################################# +# Utilities + +# read_config($conffile, $section, %opts) +# Read $conffile's default section, then $section (which takes +# precedence). %opts extends %OPTIONS and maps each option to a +# regexp validating its values. +sub read_config($$%) { + my $conffile = shift; + my $section = shift; + my %opts = (%OPTIONS, @_); + + die "No such config file $conffile\n" + unless defined $conffile and -f $conffile and -r $conffile; + + my $h = Config::Tiny::->read($conffile); + die "No such section $section\n" unless defined $h->{$section}; + + my $conf = $h->{_}; # default 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} //= 'TRUE'; + + # 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 %$conf; +} + + +# 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 +# advertize "ENABLE" in its CAPABILITY list or does not reply with +# an untagged ENABLED response with all the given extensions. +# +# - 'STDERR': Where to log debug and informational messages (default: +# STDERR) +# +# - 'name': An optional instance name to include in log messages. +# +# - 'read-only': Use only commands that don't modify the server state. +# In particular, use EXAMINE in place of SELECT for mailbox +# selection. +# +# - 'extra-attrs': An attribute or list of extra attributes to FETCH +# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE +# BODY.PEEK[]). +# +sub new($%) { + my $class = shift; + my $self = { @_ }; + bless $self, $class; + + if ($self->{type} eq 'preauth') { + require 'IPC/Open2.pm'; + my $command = $self->{command} // $self->fail("Missing preauth command"); + my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, split(/ /, $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 { + my $fpr = delete $self->{SSL_fingerprint}; + $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; + require 'IO/Socket/SSL.pm'; + $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} = {}; + + # whether we're allowed to to use read-write command + $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1; + + # where to log + $self->{STDERR} //= \*STDERR; + + # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' + # (cf RFC 3501 section 3) + $self->{_STATE} = ''; + + # 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 'FALSE') { # RFC 2595 section 5.1 + $self->fail("Server did not advertize STARTTLS capability.") + unless grep {$_ eq 'STARTTLS'} @caps; + + require 'IO/Socket/SSL.pm'; + $self->_send('STARTTLS'); + + my $fpr = delete $self->{SSL_fingerprint}; + my %sslargs = %$self{ 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(); + } + + $self->fail("Logins are disabled.") if grep {$_ eq 'LOGINDISABLED'} @caps; + my @mechs = 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; + + 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/; + $command = "AUTHENTICATE $mech"; + my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); + $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 advertize ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); + $self->_send('ENABLE '.join(' ',@extensions)); + my @enabled = @{$self->{_ENABLED} // []}; + $self->fail("Could not ENABLE $_") foreach + grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; + } + + return $self; +} + + +# Close handles when the Net::IMAP::Sync object is destroyed. +sub DESTROY($) { + my $self = shift; + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + } + $self->{STDERR}->close() if defined $self->{STDERR} and $self->{STDERR}->opened() + and $self->{STDERR} ne \*STDERR; +} + + +# $self->log($message, [...]) +# Log a $message. +sub log($@) { + my $self = shift; + return unless @_; + my $prefix = strftime "%b %e %H:%M:%S", localtime; + $prefix .= " $self->{name}" if defined $self->{name}; + $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; + $prefix .= ': '; + my $stderr = $self->{STDERR}; + print $stderr $prefix, @_, "\n"; +} + + +# $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 advertized 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) +# $self->examine($mailbox) +# Issue a SELECT or EXAMINE command for the $mailbox. (Always use +# EXAMINE if the 'read-only' flag is set.) Upon success, change the +# state to SELECTED, otherwise go back to AUTH. +sub select($$) { + my $self = shift; + my $mailbox = shift; + my $cmd = $self->{'read-only'} ? 'EXAMINE' : 'SELECT'; + $self->_select_or_examine($cmd, $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; + $self->_send('LOGOUT'); + $self->{_STATE} = 'LOGOUT'; + undef $self; +} + + +# $self->noop() +# Issue a NOOP command. +sub noop($) { + shift->_send('NOOP'); +} + + +# $self->create($mailbox) +# $self->delete($mailbox) +# CREATE or DELETE $mailbox. Requires the 'read-only' flag to be unset. +sub create($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("CREATE ".quote($mailbox)); +} +sub delete($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + #$self->_send("DELETE ".quote($mailbox)); + delete $self->{_CACHE}->{$mailbox}; + delete $self->{_PCACHE}->{$mailbox}; +} + + +# $self->rename($oldname, $newname) +# RENAME the mailbox $oldname to $newname. Requires the 'read-only' +# flag to be unset. +sub rename($$$) { + my ($self, $from, $to) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $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}; +} + + +# $self->subscribe($mailbox) +# $self->unsubscribe($mailbox) +# SUBSCRIBE or UNSUBSCRIBE $mailbox. Requires the 'read-only' flag to +# be unset. +sub subscribe($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("SUBSCRIBE ".quote($mailbox)); +} +sub unsubscribe($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("UNSUBSCRIBE ".quote($mailbox)); +} + + +# $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($uid, [...]) +# Remove the given $uid list. Croak if the server did not advertize +# "UIDPLUS" (RFC 4315) in its CAPABILITY list. +# Successfully EXPUNGEd UIDs are removed from the pending VANISHED and +# MODIFIED lists. +# Return the list of UIDs that could not be EXPUNGEd. +sub remove($@) { + my $self = shift; + my @set = @_; + $self->fail("Server did not advertize 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; + foreach my $uid (@set) { + if (exists $vanished{$uid}) { + # ignore succesfully EXPUNGEd messages + delete $vanished{$uid}; + delete $self->{_MODIFIED}->{$uid}; + } else { + push @failed, $uid; + } + } + $self->{_VANISHED} = [ keys %vanished ]; + + $self->warn("Could not EXPUNGE UID(s) ".compact_set(@failed)) if @failed; + return @failed; +} + + +# $self->append($mailbox, RFC822, [FLAGS, [INTERNALDATE, ...]]) +# Issue an APPEND command with the given mails. Croak if the server +# did not advertize "UIDPLUS" (RFC 4315) in its CAPABILITY list. +# Providing multiple mails is only allowed for servers advertizing +# "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; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.") + if $self->incapable('UIDPLUS'); + + my @appends; + while (@_) { + my $rfc822 = shift; + my $flags = shift; + my $internaldate = shift; + my $append = ''; + $append .= '('.join(' ',@$flags).') ' if defined $flags; + $append .= '"'.$internaldate.'" ' if defined $internaldate; + $append .= "{".length($rfc822)."}\r\n".$rfc822; + push @appends, $append; + } + $self->fail("Server did not advertize 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 $UIDNEXT < $1; + push @uids, $1; + } elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1); + push @uids, ($min .. $max); + $UIDNEXT = $max + 1 if $UIDNEXT < $max; + } 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} // 0) < $UIDNEXT; + } + + return @uids; +} + + +# $self->notify(@specifications) +# Issue a NOTIFY command with the given mailbox @specifications (cf RFC +# 5465 section 6) to be monitored. Croak if the server did not +# advertize "NOTIFY" (RFC 5465) in its CAPABILITY list. +sub notify($@) { + my $self = shift; + $self->fail("Server did not advertize 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->slurp() +# Turn on non-blocking IO, try to as many lines as possible, then turn +# non-blocking IO back off 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 $read = 0; + $self->{STDOUT}->blocking(0) // $self->panic("Can't turn on non-blocking IO: $!"); + while (defined (my $x = $self->_getline())) { + $self->_resp($x); + $read++ + } + $self->{STDOUT}->blocking(1) // $self->panic("Can't turn off non-blocking IO: $!"); + return $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 <UIDNEXT, the message with UID UIDNEXT-1 may +# have been deleted hence may no longer be present in $mailbox. +# * HIGHESTMODSEQ: Any change with MODSEQ <= HIGHESTMODSEQ have been +# processed. (Note however that new messages may have a lower +# MODSEQ.) Always present when UIDNEXT is present. +sub set_cache($$%) { + my $self = shift; + my $mailbox = shift // $self->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->log("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->fail("Pending VANISHED responses!") if @{$self->{_VANISHED}}; + $self->fail("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->log("Dirty mailboxes: ".join(', ', @dirty)) + : $self->log("Clean state!"); + } + return $dirty[0]; +} + + +# $self->pull_updates() +# 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 $mailbox = $self->{_SELECTED} // $self->panic(); + my $pcache = $self->{_PCACHE}->{$mailbox}; + + my (@vanished, %modified); + unless (defined $pcache->{UIDNEXT} and defined $pcache->{HIGHESTMODSEQ}) { + $self->{_MODIFIED} = {}; + $self->{_VANISHED} = []; + } + else { + my @missing; + while (%{$self->{_MODIFIED}}) { + while (my ($uid,$v) = each %{$self->{_MODIFIED}}) { + # don't filter on the fly (during FETCH responses) because + # FLAG updates can arrive while processing pull_new_messages + # for instance + if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH + next unless $uid < $pcache->{UIDNEXT} # out of bounds + and $v->[0] > $pcache->{HIGHESTMODSEQ}; # already seen + $modified{$uid} = $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} @{$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 $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; + + my $range = ''; + my $first; + foreach my $uid (@ignore) { + if ($since < $uid) { + $first //= $since; + $range .= ',' if $range ne ''; + $range .= $since; + $range .= ':'.($uid-1) if $since < $uid-1; + $since = $uid+1; + } + elsif ($since == $uid) { + $since++; + } + } + + $first //= $since; + $range .= ',' if $range ne ''; + # 2^32-1: don't use '*' since the highest UID can be known already + $range .= "$since:4294967295"; + + my $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT}; + $self->panic() unless defined $UIDNEXT and $UIDNEXT > 0; # sanity check + + $self->_send("UID FETCH $range ($attrs)", $callback) if $first < $UIDNEXT;; + + # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ + # since there might be pending updates) + $self->set_cache($mailbox, %{$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(%) { my %mail = @_; $listed{$mail{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($_); + } + } + } + + 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}; + } + } + } + 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. +sub _getline($;$) { + my $self = shift; + my $msg = shift // ''; + + my $x = $self->{STDOUT}->getline() // return; # non-blocking IO + $x =~ s/\r\n\z// or $self->panic($x); + $self->log("S: $msg", $x) if $self->{debug}; + return $x; +} + + +# $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 $prefix = $tag.' '; + while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { + my ($str, $len) = ($1, $2); + my $lit = substr $command, 0, $len, ''; # consume the literal + + if ($self->_capable('LITERAL+')) { # RFC 2088 LITERAL+ + $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len+}") if $self->{debug}; + $self->{STDIN}->print($prefix, $str, "{$len+}\r\n"); + } + else { + $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len}") if $self->{debug}; + $self->{STDIN}->print($prefix, $str, "{$len}\r\n"); + $self->{STDIN}->flush(); + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + } + $self->{STDIN}->print($lit); + $prefix = ''; + } + $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $command) if $self->{debug}; + $self->{STDIN}->print($prefix, $command, "\r\n"); + $self->{STDIN}->flush(); + + my $r; + # wait for the answer + while (defined($_ = $self->_getline())) { + if (s/\A\Q$tag\E (OK|NO|BAD) //) { + $IMAP_cond = $1; + $IMAP_text = $1.' '.$_; + $self->_resp_text($_); + $self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK'; + $r = $1; + last; + } + else { + $self->_resp($_, $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) +# Issue a SELECT or EXAMINE command for the $mailbox. (Always use +# EXAMINE if the 'read-only' flag is set.) Upon success, change the +# state to SELECTED, otherwise go back to AUTH. +sub _select_or_examine($$$) { + my $self = shift; + my $command = shift; + my $mailbox = shift; + + 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); + $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " + ."1:".($pcache->{UIDNEXT}-1)."))" + if $self->_enabled('QRESYNC') and + ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 0) > 0; + + if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { + # A mailbox is currently selected and the server advertizes + # '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'; + if ($self->_send($command) eq 'OK') { + $self->{_STATE} = 'SELECTED'; + } else { + delete $self->{_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/) { + print STDERR $_, "\n"; + } + 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 + my $count = $1; + my @acc; + my $buf; + while ($count > 0) { + my $n = $self->{STDOUT}->read($buf, $count); + push @acc, $buf; + $count -= $n; + } + $$stream = $self->_getline('[...]'); + return join ('', @acc); + } + 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 //) { + exit 0; + } + 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, $flags) = ($2, $1); + my @flags = defined $flags ? split(/ /, $flags) : (); + 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; + $callback->($mailbox, $delim, @flags) 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 + if defined $pcache->{UIDNEXT} and $1 < $pcache->{UIDNEXT}; + } + elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); + $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional + $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that + push @{$self->{_VANISHED}}, grep {$_ < $pcache->{UIDNEXT}} ($min .. $max) + if defined $pcache->{UIDNEXT}; + } + } + } + } + elsif (s/\A\+ //) { + if (defined $callback and $cmd eq 'AUTHENTICATE') { + my $x = $callback->($_); + print STDERR "C: ", $x, "\n" if $self->{debug}; + $self->{STDIN}->print($x, "\r\n"); + $self->{STDIN}->flush(); + } + } + else { + $self->panic("Unexpected response: ", $_); + } +} + + +############################################################################# + +return 1; |