diff options
Diffstat (limited to 'interimap')
-rwxr-xr-x | interimap | 1230 |
1 files changed, 768 insertions, 462 deletions
@@ -2,7 +2,7 @@ #---------------------------------------------------------------------- # Fast bidirectional synchronization for QRESYNC-capable IMAP servers -# Copyright © 2015-2018 Guilhem Moulin <guilhem@fripost.org> +# Copyright © 2015-2019 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 @@ -22,17 +22,18 @@ use v5.14.2; use strict; use warnings; -our $VERSION = '0.4'; +our $VERSION = '0.5'; my $NAME = 'interimap'; +my $DATABASE_VERSION = 1; use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat bundling auto_version/; -use DBI (); +use DBI ':sql_types'; use DBD::SQLite::Constants ':file_open'; use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC/; use List::Util 'first'; use lib 'lib'; -use Net::IMAP::InterIMAP 0.0.4 qw/xdg_basedir read_config compact_set/; +use Net::IMAP::InterIMAP 0.0.5 qw/xdg_basedir read_config compact_set/; # Clean up PATH $ENV{PATH} = join ':', qw{/usr/bin /bin}; @@ -68,7 +69,7 @@ usage(1) if defined $COMMAND and (defined $CONFIG{watch} or defined $CONFIG{noti usage(1) if $CONFIG{target} and !(defined $COMMAND and ($COMMAND eq 'delete' or $COMMAND eq 'rename')); $CONFIG{watch} = $CONFIG{notify} ? 900 : 60 if (defined $CONFIG{watch} or $CONFIG{notify}) and !$CONFIG{watch}; @ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive -die "Invalid mailbox name $_" foreach grep !/\A([\x01-\x7F]+)\z/, @ARGV; +die "Invalid mailbox name $_" foreach grep !/\A[\x01-\x7F]+\z/, @ARGV; my $CONF = do { @@ -78,12 +79,13 @@ my $CONF = do { , [qw/_ local remote/] , database => qr/\A(\P{Control}+)\z/ , logfile => qr/\A(\/\P{Control}+)\z/ + , 'list-reference' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]*)\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/ + , 'list-select-opts' => qr/\A([\x20\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, $LOGGER_FD); +my ($DBFILE, $LOGGER_FD, %LIST); { $DBFILE = $CONF->{_}->{database} if defined $CONF->{_}; @@ -104,6 +106,41 @@ my ($DBFILE, $LOGGER_FD); elsif ($CONFIG{debug}) { $LOGGER_FD = \*STDERR; } + + $LIST{mailbox} = [@ARGV]; + if (!defined $COMMAND or $COMMAND eq 'repair') { + if (!@ARGV and defined (my $v = $CONF->{_}->{'list-mailbox'})) { + my @mailbox; + do { + if ($v =~ s/\A[\x21\x23-\x27\x2A-\x5B\x5D-\x7A\x7C-\x7E]+//p) { + push @mailbox, ${^MATCH}; + } elsif ($v =~ s/\A\"((?: + [\x20\x21\x23-\x5B\x5D-\x7E] | # the above plus \x20\x28\x29\x7B + (?:\\(?:[\x22\x5C0abtnvfr] | x\p{AHex}{2})) # quoted char or hex-encoded pair + )+)\"//x) { + push @mailbox, $1 =~ s/\\(?:[\x22\x5C0abtnvfr]|x\p{AHex}{2})/"\"${^MATCH}\""/greep; + } + } while ($v =~ s/\A\s+//); + die "Invalid value for list-mailbox: ".$CONF->{_}->{'list-mailbox'}."\n" if $v ne ""; + $LIST{mailbox} = \@mailbox; + } + $LIST{'select-opts'} = uc($CONF->{_}->{'list-select-opts'}) + if defined $CONF->{_}->{'list-select-opts'} and $CONF->{_}->{'list-select-opts'} ne ""; + $LIST{params} = [ "SUBSCRIBED" ]; # RFC 5258 - LIST Command Extensions + push @{$LIST{params}}, "STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)" + # RFC 5819 - Returning STATUS Information in Extended LIST + unless $CONFIG{notify}; + } + if (defined (my $t = $CONFIG{target})) { + @$t = map { split(",", $_) } @$t; + die "Invalid target $_\n" foreach grep !/^(?:local|remote|database)$/, @$t; + $CONFIG{target} = {}; + $CONFIG{target}->{$_} = 1 foreach @$t; + } else { + $CONFIG{target} = {}; + $CONFIG{target}->{$_} = 1 foreach qw/local remote database/; + } + $CONF->{$_}->{'list-reference'} //= "" foreach qw/local remote/; } my $DBH; @@ -120,15 +157,13 @@ $SIG{TERM} = sub { cleanup(); exit 0; }; ############################################################################# -# Open the database and create tables - +# Open (and maybe create) the database { my $dbi_data_source = "dbi:SQLite:dbname=".$DBFILE; my %dbi_attrs = ( AutoCommit => 0, RaiseError => 1, - sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not sqlite_use_immediate_transaction => 1, sqlite_open_flags => SQLITE_OPEN_READWRITE ); @@ -137,63 +172,11 @@ $SIG{TERM} = sub { cleanup(); exit 0; }; $DBH = DBI::->connect($dbi_data_source, undef, undef, \%dbi_attrs); $DBH->sqlite_busy_timeout(250); - $DBH->do('PRAGMA locking_mode = EXCLUSIVE'); - $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) - ], - - # We have no version number in the schema, but if we ever need a - # migration, we'll add a new table, and assume version 1.0 if - # the table is missing. - ); - - # 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(); - } - } + # Try to lock the database before any network traffic so we can fail + # early if the database is already locked. + $DBH->do("PRAGMA locking_mode = EXCLUSIVE"); + $DBH->{AutoCommit} = 1; # turned back off later + $DBH->do("PRAGMA foreign_keys = OFF"); # toggled later (no-op if not in autocommit mode) } sub msg($@) { @@ -216,26 +199,17 @@ sub logger($@) { $prefix .= "$name: " if defined $name; $LOGGER_FD->say($prefix, @_); } +sub fail($@) { + my $name = shift; + msg($name, "ERROR: ", @_); + exit 1; +} logger(undef, ">>> $NAME $VERSION"); ############################################################################# # Connect to the local and remote IMAP servers -my $LIST = '"" '; -my @LIST_PARAMS; -my %LIST_PARAMS_STATUS = (STATUS => [qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/]); -if (!defined $COMMAND or $COMMAND eq 'repair') { - $LIST = '('.uc($CONF->{_}->{'list-select-opts'}).') '.$LIST if defined $CONF->{_}->{'list-select-opts'}; - $LIST .= (defined $CONF->{_}->{'list-mailbox'} ? '('.$CONF->{_}->{'list-mailbox'}.')' : '*') unless @ARGV; - @LIST_PARAMS = ('SUBSCRIBED'); - push @LIST_PARAMS, map { "$_ (".join(' ', @{$LIST_PARAMS_STATUS{$_}}).")" } keys %LIST_PARAMS_STATUS - unless $CONFIG{notify}; -} -$LIST .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0]) - : ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV; - - foreach my $name (qw/local remote/) { my %config = %{$CONF->{$name}}; $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/; @@ -252,39 +226,292 @@ foreach my $name (qw/local remote/) { die "Non LIST-STATUS-capable IMAP server.\n" if !$CONFIG{notify} and $client->incapable('LIST-STATUS'); } -@{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/; +# Pretty-print hierarchy delimiter: DQUOTE QUOTED-CHAR DQUOTE / nil +sub print_delimiter($) { + my $d = shift // return "NIL"; + $d = "\\".$d if $d eq "\\" or $d eq "\""; + return "\"".$d."\""; +} + +# Return the delimiter of the default namespace or reference, and cache the +# result. Use the cached value if present, otherwise issue a new LIST +# command with the empty mailbox. +sub get_delimiter($$$) { + my ($name, $imap, $ref) = @_; + + # Use the cached value if present + return $imap->{delimiter} if exists $imap->{delimiter}; + + my (undef, $d) = $imap->{client}->list($ref." \"\""); # $ref is already quoted + my @d = values %$d if defined $d; + # While multiple LIST responses may happen in theory, we've issued a + # single LIST command, so it's fair to expect a single reponse with + # a hierarchy delimiter of the root node or reference (we can't + # match the root against the reference as it might not be rooted). + fail($name, "Missing or unexpected (unsolicited) LIST response.") unless $#d == 0; + + return $imap->{delimiter} = $d[0]; # cache value and return it +} + +# List mailboxes; don't return anything but update $IMAP->{$name}->{mailboxes} +sub list_mailboxes($) { + my $name = shift; + my $imap = $IMAP->{$name}; + my $ref = Net::IMAP::InterIMAP::quote($CONF->{$name}->{'list-reference'}); + + my $list = ""; + $list .= "(" .$LIST{'select-opts'}. ") " if defined $LIST{'select-opts'}; + $list .= $ref." "; + + my @mailboxes = @{$LIST{mailbox}}; + my $cached_delimiter = exists $imap->{delimiter} ? 1 : 0; + if (grep { index($_,"\x00") >= 0 } @mailboxes) { + # some mailbox names contain null characters: substitute them with the hierarchy delimiter + my $d = get_delimiter($name, $imap, $ref) // + fail($name, "Mailbox name contains null characters but the namespace is flat!"); + s/\x00/$d/g foreach @mailboxes; + } + + $list .= $#mailboxes < 0 ? "*" + : $#mailboxes == 0 ? Net::IMAP::InterIMAP::quote($mailboxes[0]) + : "(".join(" ", map {Net::IMAP::InterIMAP::quote($_)} @mailboxes).")"; + my ($mbx, $delims) = $imap->{client}->list($list, @{$LIST{params} // []}); + $imap->{mailboxes} = $mbx; + + # INBOX exists in a namespace of its own, so it may have a different separator. + # All other mailboxes MUST have the same separator though, per 3501 sec. 7.2.2 + # and https://www.imapwiki.org/ClientImplementation/MailboxList#Hierarchy_separators + # (We assume all list-mailbox arguments given live in the same namespace. Otherwise + # the user needs to start multiple interimap instances.) + delete $delims->{INBOX}; + + unless (exists $imap->{delimiter}) { + # if the delimiter is still unknown (meaning no names in @{$LIST{mailbox}} + # contains null characters) we now cache it + if (%$delims) { + # got a non-INBOX LIST reply, use the first one as authoritative value + my ($m) = sort keys %$delims; + $imap->{delimiter} = delete $delims->{$m}; + } else { + # didn't get a non-INBOX LIST reply so we need to explicitely query + # the hierarchy delimiter + get_delimiter($name, $imap, $ref); + } + } + logger($name, "Using ", print_delimiter($imap->{delimiter}), + " as hierarchy delimiter") if !$cached_delimiter and $CONFIG{debug}; + + # Ensure all LISTed delimiters (incl. INBOX's children, although they're + # in a different namespace -- we treat INBOX itself separately, but not + # its children) match the one at the top level (root or reference). + my $d = $imap->{delimiter}; + foreach my $m (keys %$delims) { + fail($name, "Mailbox $m has hierarchy delimiter ", print_delimiter($delims->{$m}), + ", while ", print_delimiter($d), " was expected.") + if (defined $d xor defined $delims->{$m}) + or (defined $d and defined $delims->{$m} and $d ne $delims->{$m}); + } +} + +list_mailboxes("local"); +if (defined (my $d = $IMAP->{local}->{delimiter})) { + # substitute the local delimiter with null characters in the mailbox list + s/\Q$d\E/\x00/g foreach @{$LIST{mailbox}}; +} +list_mailboxes("remote"); + +# Ensure local and remote namespaces are either both flat, or both hierarchical. +# (We can't mirror a hierarchical namespace to a flat one.) +fail(undef, "Local and remote namespaces are neither both flat nor both hierarchical ", + "(local ", print_delimiter($IMAP->{local}->{delimiter}), ", ", + "remote ", print_delimiter($IMAP->{remote}->{delimiter}), ").") + if defined $IMAP->{local}->{delimiter} xor defined $IMAP->{remote}->{delimiter}; + + +############################################################################## +# Create or update database schema (delayed until after the IMAP +# connections and mailbox LISTing as we need to know the hierarchy +# delimiter for the schema migration). + +{ + # 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`. + my @schema = ( + mailboxes => [ + q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT}, + # to avoid caching hierachy delimiter of mailbox names forever we replace it + # with '\0' in that table; the substitution is safe since null characters are + # not allowed within mailbox names + q{mailbox BLOB COLLATE BINARY NOT NULL CHECK (mailbox != '') UNIQUE}, + q{subscribed BOOLEAN NOT NULL} + ], + local => [ + q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)}, + # no UNIQUE constraint on UIDVALIDITY as two mailboxes may share the same value + 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 (/!\ converted to 8-byte signed integer) + # one-to-one correspondence between local.idx and remote.idx + ], + remote => [ + q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)}, + # no UNIQUE constraint on UIDVALIDITY as two mailboxes may share the same value + 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 (/!\ converted to 8-byte signed integer) + # 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) + ], + ); + + # Use the user_version PRAGMA (0 if unset) to keep track of schema + # version https://sqlite.org/pragma.html#pragma_user_version + my ($schema_version) = $DBH->selectrow_array("PRAGMA user_version"); + + if ($schema_version < $DATABASE_VERSION) { + # schema creation or upgrade required + $DBH->begin_work(); + if ($schema_version == 0) { + my $sth = $DBH->table_info(undef, undef, undef, "TABLE"); + unless (defined $sth->fetch()) { + # there are no tables, create everything + msg(undef, "Creating new schema in database file $DBFILE"); + for (my $i = 0; $i <= $#schema; $i+=2) { + $DBH->do("CREATE TABLE $schema[$i] (".join(", ", @{$schema[$i+1]}).")"); + } + goto SCHEMA_DONE; # skip the below migrations + } + } + msg(undef, "Upgrading database version from $schema_version"); + # 12-step procedure from https://www.sqlite.org/lang_altertable.html + if ($schema_version < 1) { + fail(undef, "Local and remote hierachy delimiters differ ", + "(local ", print_delimiter($IMAP->{local}->{delimiter}), ", ", + "remote ", print_delimiter($IMAP->{remote}->{delimiter}), "), ", + "refusing to update \`mailboxes\` table.") + if defined $IMAP->{local}->{delimiter} and defined $IMAP->{remote}->{delimiter} + # we failed earlier if only one of them was NIL + and $IMAP->{local}->{delimiter} ne $IMAP->{remote}->{delimiter}; + $DBH->do("CREATE TABLE _tmp${DATABASE_VERSION}_mailboxes (". join(", ", + q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT}, + q{mailbox BLOB COLLATE BINARY NOT NULL CHECK (mailbox != '') UNIQUE}, + q{subscribed BOOLEAN NOT NULL} + ).")"); + if (defined (my $d = $IMAP->{local}->{delimiter})) { + # local and remote delimiters match, replace them with null characters + my $sth = $DBH->prepare("INSERT INTO _tmp${DATABASE_VERSION}_mailboxes + SELECT idx, CAST(REPLACE(mailbox, ?, x'00') AS BLOB), subscribed FROM mailboxes"); + $sth->bind_param(1, $IMAP->{local}->{delimiter}, SQL_VARCHAR); + $sth->execute(); + } else { + # treat all mailboxes as flat (\NoInferiors names) + $DBH->do("INSERT INTO _tmp${DATABASE_VERSION}_mailboxes SELECT * FROM mailboxes"); + } + $DBH->do("DROP TABLE mailboxes"); + $DBH->do("ALTER TABLE _tmp${DATABASE_VERSION}_mailboxes RENAME TO mailboxes"); + } + fail("database", "Broken referential integrity! Refusing to commit changes.") + if defined $DBH->selectrow_arrayref("PRAGMA foreign_key_check"); + SCHEMA_DONE: + $DBH->do("PRAGMA user_version = $DATABASE_VERSION"); + $DBH->commit(); + } + $DBH->do("PRAGMA foreign_keys = ON"); # no-op if not in autocommit mode + $DBH->{AutoCommit} = 0; # always explicitly commit changes +} ############################################################################## # # Add a new mailbox to the database. -my $STH_INSERT_MAILBOX = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); +# WARN: does not commit changes! +sub db_create_mailbox($$) { + my ($mailbox, $subscribed) = @_;; + state $sth = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); + $sth->bind_param(1, $mailbox, SQL_BLOB); + $sth->bind_param(2, $subscribed, SQL_BOOLEAN); + my $r = $sth->execute(); + msg("database", fmt("Created mailbox %d", $mailbox)); + return $r; +} # 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" +sub db_get_mailbox_idx($) { + my $mailbox = shift; + state $sth = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?}); + $sth->bind_param(1, $mailbox, SQL_BLOB); + $sth->execute(); + my ($idx, $subscribed) = $sth->fetchrow_array(); + die if defined $sth->fetch(); # safety check (we have a UNIQUE contstraint though) + return wantarray ? ($idx, $subscribed) : $idx; +} + +# Transform mailbox name from internal representation (with \0 as hierarchy delimiters +# and without reference prefix) to a name understandable by the local/remote IMAP server. +sub mbx_name($$) { + my ($name, $mailbox) = @_; + my $x = $name // "local"; # don't add reference if $name is undefined + if (defined (my $d = $IMAP->{$x}->{delimiter})) { + $mailbox =~ s/\x00/$d/g; + } elsif (!exists $IMAP->{$x}->{delimiter} or index($mailbox,"\x00") >= 0) { + die; # safety check } - return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef; + return defined $name ? ($CONF->{$name}->{"list-reference"} . $mailbox) : $mailbox; +} + +# Transform mailbox name from local/remote IMAP server to the internal representation +# (with \0 as hierarchy delimiters and without reference prefix). Return undef if +# the name doesn't start with the right reference. +sub mbx_unname($$) { + my ($name, $mailbox) = @_; + return unless defined $mailbox; + + my $ref = $CONF->{$name}->{"list-reference"}; + return unless rindex($mailbox, $ref, 0) == 0; # not for us + $mailbox = substr($mailbox, length $ref); + + if (defined (my $d = $IMAP->{$name}->{delimiter})) { + $mailbox =~ s/\Q$d\E/\x00/g; + } elsif (!exists $IMAP->{$name}->{delimiter}) { + die; # safety check + } + return $mailbox; +} + +# Format a message with format controls for local/remote/database mailbox names. +sub fmt($@) { + my $msg = shift; + $msg =~ s/%([lrds])/ + $1 eq "l" ? mbx_name("local", shift) + : $1 eq "r" ? mbx_name("remote", shift) + : $1 eq "d" ? mbx_name(undef, shift) + : $1 eq "s" ? shift + : die + /ge; + return $msg; } # 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; + my ($ne, $ns) = (lc '\NonExistent', lc '\NoSelect'); + return (defined $attrs and !grep {my $a = lc; $a eq $ne or $a eq $ns} @$attrs) ? 1 : 0; } # Return true if $mailbox is subscribed to on $name @@ -299,36 +526,33 @@ sub mbx_subscribed($$) { # 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 = ?}); - + if (defined (my $d = $IMAP->{local}->{delimiter})) { + s/\Q$d\E/\x00/g foreach @ARGV; + } + my @statements = map { $DBH->prepare("DELETE FROM $_ WHERE idx = ?") } + # non-referenced tables first to avoid violating + # FOREIGN KEY constraints + qw/mapping local remote mailboxes/ + if @ARGV and $CONFIG{target}->{database}; 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 + my $idx = db_get_mailbox_idx($mailbox); # 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); + my $mbx = mbx_name($name, $mailbox); + $IMAP->{$name}->{client}->delete($mbx) + if $CONFIG{target}->{$name} and mbx_exists($name, $mbx); } - 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; - + if (defined $idx and $CONFIG{target}->{database}) { + foreach my $sth (@statements) { + $sth->bind_param(1, $idx, SQL_INTEGER); + $sth->execute(); + } $DBH->commit(); - msg('database', "Removed mailbox $mailbox") if $r4; + msg("database", fmt("Removed mailbox %d", $mailbox)); } } exit 0; @@ -340,62 +564,66 @@ if (defined $COMMAND and $COMMAND eq 'delete') { # elsif (defined $COMMAND and $COMMAND eq 'rename') { my ($from, $to) = @ARGV; + if (defined (my $d = $IMAP->{local}->{delimiter})) { + s/\Q$d\E/\x00/g foreach ($from, $to); + } # 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); + my $idx = db_get_mailbox_idx($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; - } + my $mbx = mbx_name($name, $to); + next unless $CONFIG{target}->{$name} and mbx_exists($name, $mbx); + fail($name, fmt("Mailbox %s exists. Run `$NAME --target=$name --delete %d` to delete.", $mbx, $to)); } # 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; - } + fail("database", fmt("Mailbox %d exists. Run `$NAME --target=database --delete %d` to delete.", $to, $to)) + if $CONFIG{target}->{database} and defined db_get_mailbox_idx($to); - # 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 + # rename $from to $to on servers where $from if LISTed. 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); + next unless $CONFIG{target}->{$name}; + my ($from, $to) = ( mbx_name($name,$from), mbx_name($name, $to) ); + # don't use mbx_exists() here, as \NonExistent names can be renamed + # too (for instance if they have children) + $IMAP->{$name}->{client}->rename($from, $to) + if defined $IMAP->{$name}->{mailboxes}->{$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,?) = ? + if ($CONFIG{target}->{database}) { + my $r = 0; + if (defined $idx) { + my $sth_rename_mailbox = $DBH->prepare(q{ + UPDATE mailboxes SET mailbox = ? WHERE idx = ? }); - $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix); + $sth_rename_mailbox->bind_param(1, $to, SQL_BLOB); + $sth_rename_mailbox->bind_param(2, $idx, SQL_INTEGER); + $r += $sth_rename_mailbox->execute(); } + # now rename the children as well + my $prefix = $from."\x00"; + my $sth_rename_children = $DBH->prepare(q{ + UPDATE mailboxes SET mailbox = CAST(? || SUBSTR(mailbox,?) AS BLOB) + WHERE SUBSTR(mailbox,1,?) = ? + }); + $sth_rename_children->bind_param(1, $to, SQL_BLOB); + $sth_rename_children->bind_param(2, length($prefix), SQL_INTEGER); + $sth_rename_children->bind_param(3, length($prefix), SQL_INTEGER); + $sth_rename_children->bind_param(4, $prefix, SQL_BLOB); + $r += $sth_rename_children->execute(); + $DBH->commit(); - msg('database', "Renamed mailbox $from to $to") if $r; + msg("database", fmt("Renamed mailbox %d to %d", $from, $to)) if $r > 0; } exit 0; } @@ -406,165 +634,97 @@ elsif (defined $COMMAND and $COMMAND eq 'rename') { sub sync_mailbox_list() { my (%mailboxes, @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 = ?}); + state $sth_subscribe = $DBH->prepare(q{ + UPDATE mailboxes SET subscribed = ? WHERE idx = ? + }); + + foreach my $name (qw/local remote/) { + foreach my $mbx (keys %{$IMAP->{$name}->{mailboxes}}) { + # exclude names not starting with the given LIST reference; for instance + # if "list-mailbox" specifies a name starting with a "breakout" character + $mbx = mbx_unname($name, $mbx) // next; + + # exclude ignored mailboxes (taken from the default config as it doesn't + # make sense to ignore mailboxes from one side but not the other + next if !@ARGV and defined $CONF->{_}->{"ignore-mailbox"} + and $mbx =~ /$CONF->{_}->{"ignore-mailbox"}/o; + $mailboxes{$mbx} = 1; + } + } 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/; + my ($lMailbox, $rMailbox) = map {mbx_name($_, $mailbox)} qw/local remote/; + my $lExists = mbx_exists("local", $lMailbox); + my $rExists = mbx_exists("remote", $rMailbox); 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 + push @mailboxes, $mailbox; + my ($idx, $subscribed) = db_get_mailbox_idx($mailbox); if ($lExists and $rExists) { # $mailbox exists on both sides - my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/; + my $lSubscribed = mbx_subscribed("local", $lMailbox); + my $rSubscribed = mbx_subscribed("remote", $rMailbox); 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); + my ($imap, $mbx) = $lSubscribed ? ($lIMAP, $lMailbox) : ($rIMAP, $rMailbox); + $imap->unsubscribe($mbx); + } else { # subscribe + my ($imap, $mbx) = $lSubscribed ? ($rIMAP, $rMailbox) : ($lIMAP, $lMailbox); + $imap->subscribe($mbx); } # 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"); + $sth_subscribe->bind_param(1, $subscribed, SQL_BOOLEAN); + $sth_subscribe->bind_param(2, $idx, SQL_INTEGER); + $sth_subscribe->execute(); $DBH->commit(); } - # $mailbox is either subscribed on both servers, or subscribed on both + # $mailbox is either subscribed on both servers, or unsubscribed 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"); + # $lSubscribed == $rSubscribed but database needs updating + $sth_subscribe->bind_param(1, $lSubscribed, SQL_BOOLEAN); + $sth_subscribe->bind_param(2, $idx, SQL_INTEGER); + $sth_subscribe->execute(); $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; + db_create_mailbox($mailbox, $subscribed); + $IMAP->{local}->{client}->subscribe($lMailbox) if $subscribed and !$lSubscribed; + $IMAP->{remote}->{client}->subscribe($rMailbox) 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; + elsif ($lExists or $rExists) { + # $mailbox is on one server only + fail("database", fmt("Mailbox %d exists. Run `$NAME --target=database --delete %d` to delete.", $mailbox, $mailbox)) + if defined $idx; + my ($name1, $name2, $mbx1, $mbx2) = $lExists ? ("local", "remote", $lMailbox, $rMailbox) + : ("remote", "local", $rMailbox, $lMailbox); + my $subscribed = mbx_subscribed($name1, $mbx1); + db_create_mailbox($mailbox, $subscribed); + $IMAP->{$name2}->{client}->create($mbx2, 1); + $IMAP->{$name2}->{client}->subscribe($mbx2) if $subscribed; $DBH->commit(); } } return @mailboxes; } -my @MAILBOXES = sync_mailbox_list(); ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/; +my @MAILBOXES = sync_mailbox_list(); my $ATTRS = join ' ', qw/MODSEQ FLAGS INTERNALDATE BODY.PEEK[]/; ############################################################################# # 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 +# Download some missing UIDs from $source; returns the new allocated UIDs sub download_missing($$$@) { my $idx = shift; my $mailbox = shift; @@ -572,22 +732,22 @@ sub download_missing($$$@) { my @set = @_; my @uids; - my $target = $source eq 'local' ? 'remote' : 'local'; + my ($target, $f) = $source eq 'local' ? ('remote', '%l') : ('local', '%r'); + my $prefix = fmt("%s($f)", $source, $mailbox) unless $CONFIG{quiet}; my ($buff, $bufflen) = ([], 0); undef $buff if ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND'); - my $attrs = $ATTRS.' ENVELOPE'; - ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) { + ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($ATTRS ENVELOPE)", 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 defined $from->[0]->[2] and defined $from->[0]->[3]) - ? $from->[0]->[2].'@'.$from->[0]->[3] : ''; - msg(undef, "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet}; - + unless ($CONFIG{quiet}) { + my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4]; + $from = (defined $from and defined $from->[0]->[2] and defined $from->[0]->[3]) + ? $from->[0]->[2].'@'.$from->[0]->[3] : ''; + msg($prefix, "UID $mail->{UID} from <$from> ($mail->{INTERNALDATE})"); + } 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; @@ -601,18 +761,24 @@ sub flag_conflict($$$$$) { 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)."); - + msg(undef, fmt("WARNING: Conflicting flag update in %d for local UID $lUID (%s) ". + "and remote UID $rUID (%s). Setting both to the union (%s).", + $mailbox, $lFlags, $rFlags, $flags)); return $flags } -# Delete a mapping ($idx, $lUID) +# Delete a mapping ($idx, $lUID) from the database +# WARN: Never commit before the messages have been EXPUNGEd on both sides! sub delete_mapping($$) { my ($idx, $lUID) = @_; - my $r = $STH_DELETE_MAPPING->execute($idx, $lUID); - die if $r > 1; # sanity check + state $sth = $DBH->prepare(q{ + DELETE FROM mapping WHERE idx = ? and lUID = ? + }); + $sth->bind_param(1, $idx, SQL_INTEGER); + $sth->bind_param(2, $lUID, SQL_INTEGER); + my $r = $sth->execute(); + die if $r > 1; # safety check (even if we have a UNIQUE constraint) msg('database', "WARNING: Can't delete (idx,lUID) = ($idx,$lUID)") if $r == 0; } @@ -624,25 +790,23 @@ sub delete_mapping($$) { # 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. +# of length (once compacted) 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) = @_; +sub sample($$) { + my ($count, $sth) = @_; return unless $count > 0; - my ($n, $uids, $min, $max); - $sth->execute($idx); + + $sth->execute(); # /!\ assume placeholders are bound already 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) { + } elsif ($k == $min - 1) { $min--; - } - else { + } else { $n += $max - $min + 1; $uids = ($min == $max ? $min : "$min:$max") .(defined $uids ? ','.$uids : ''); @@ -655,9 +819,10 @@ sub sample($$$) { } if (!defined $uids or length($uids) <= 64) { $n += $max - $min + 1; - $uids = ($min == $max ? $min : "$min:$max") - .(defined $uids ? ','.$uids : ''); + $uids = ($min == $max ? $min : "$min:$max") + . (defined $uids ? ','.$uids : ''); } + die unless $n <= $count; # impossible return ( ($count - $n + 1).':'.$count, $uids ); } @@ -666,12 +831,33 @@ sub sample($$$) { 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 + # Count messages + state $sth_count_messages = $DBH->prepare(q{ + SELECT COUNT(*) FROM mapping WHERE idx = ? + }); + $sth_count_messages->bind_param(1, $idx, SQL_INTEGER); + $sth_count_messages->execute(); + + my ($count) = $sth_count_messages->fetchrow_array(); + $sth_count_messages->finish(); + + # List last 1024 messages UIDs + state $sth_last_lUIDs = $DBH->prepare(q{ + SELECT lUID FROM mapping + WHERE idx = ? + ORDER BY lUID DESC + LIMIT 1024 + }); + state $sth_last_rUIDs = $DBH->prepare(q{ + SELECT rUID FROM mapping + WHERE idx = ? + ORDER BY rUID DESC + LIMIT 1024 + }); - $lIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_LOCAL)); - $rIMAP->select($mailbox, sample($idx, $count, $STH_LASTUIDs_REMOTE)); + $_->bind_param(1, $idx, SQL_INTEGER) foreach ($sth_last_lUIDs, $sth_last_rUIDs); + $lIMAP->select(mbx_name(local => $mailbox), sample($count, $sth_last_lUIDs)); + $rIMAP->select(mbx_name(remote => $mailbox), sample($count, $sth_last_rUIDs)); } @@ -679,59 +865,56 @@ sub select_mbx($$) { # (in a very crude way, by downloading all existing UID with their flags) sub repair($) { my $mailbox = shift; + my $idx = db_get_mailbox_idx($mailbox) // return; # not in the database + my $cache = db_get_cache_by_idx($idx) // return; # no cache - $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 + # don't use select_mbx() as we don't need to sample here + $lIMAP->select(mbx_name(local => $mailbox)); + $rIMAP->select(mbx_name(remote => $mailbox)); # 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 (%lVanished, %rVanished); + $lVanished{$_} = 1 foreach @$lVanished; + $rVanished{$_} = 1 foreach @$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())) { + # process each pair ($lUID,$rUID) found in the mapping table for the given index, + # and compare with the result from the IMAP servers to detect anomalies + state $sth_get_mappings = $DBH->prepare(q{ + SELECT lUID,rUID FROM mapping WHERE idx = ? + }); + $sth_get_mappings->bind_param(1, $idx, SQL_INTEGER); + $sth_get_mappings->execute(); + while (defined (my $row = $sth_get_mappings->fetchrow_arrayref())) { my ($lUID, $rUID) = @$row; - if (defined $lModified->{$lUID} and defined $rModified->{$rUID}) { + if (defined (my $l = $lModified->{$lUID}) and defined (my $r = $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]); + my ($lModSeq, $lFlags) = @$l; + my ($rModSeq, $rFlags) = @$r; if ($lFlags eq $rFlags) { - # no conflict + # no conflict, whee } - elsif ($lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and - $rModified->{$rUID}->[0] > $cache->{rHIGHESTMODSEQ}) { + elsif ($lModSeq <= $cache->{lHIGHESTMODSEQ} and $rModSeq > $cache->{rHIGHESTMODSEQ}) { # set $lUID to $rFlags $lToUpdate{$rFlags} //= []; push @{$lToUpdate{$rFlags}}, $lUID; } - elsif ($lModified->{$lUID}->[0] > $cache->{lHIGHESTMODSEQ} and - $rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) { + elsif ($lModSeq > $cache->{lHIGHESTMODSEQ} and $rModSeq <= $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}; + msg(undef, fmt("WARNING: Missed flag update in %d for (lUID,rUID) = ($lUID,$rUID). Repairing.", $mailbox)) + if $lModSeq <= $cache->{lHIGHESTMODSEQ} and $rModSeq <= $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} //= []; @@ -741,17 +924,16 @@ sub repair($) { } } 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; - } + push @delete_mapping, $lUID; + msg(undef, fmt("WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from %d. Repairing.", $mailbox)) + unless $lVanished{$lUID} and $rVanished{$rUID}; } 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."); + msg(fmt("local(%l)", $mailbox), "WARNING: UID $lUID disappeared. Downloading remote UID $rUID again."); push @rMissing, $rUID; } } @@ -760,7 +942,7 @@ sub repair($) { if ($rVanished{$rUID}) { push @lToRemove, $lUID; } else { - msg("remote($mailbox)", "WARNING: UID $rUID disappeared. Downloading local UID $lUID again."); + msg(fmt("remote(%r)",$mailbox), "WARNING: UID $rUID disappeared. Downloading local UID $lUID again."); push @lMissing, $lUID; } } @@ -787,21 +969,20 @@ sub repair($) { $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) " + msg(fmt("remote(%r)",$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) " + msg(fmt("local(%l)",$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."); + msg(fmt("remote(%r)",$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."); + msg(fmt("local(%l)",$mailbox), "WARNING: No match for modified remote UID $rUID. Downloading again."); push @rMissing, $rUID; } @@ -822,7 +1003,19 @@ sub sync_known_messages($$) { my ($idx, $mailbox) = @_; my $update = 0; - # loop since processing might produce VANISHED or unsollicited FETCH responses + # Find local/remote UID from the mapping table. + state $sth_get_local_uid = $DBH->prepare(q{ + SELECT lUID + FROM mapping + WHERE idx = ? and rUID = ? + }); + state $sth_get_remote_uid = $DBH->prepare(q{ + SELECT rUID + FROM mapping + WHERE idx = ? and lUID = ? + }); + + # loop since processing might produce VANISHED or unsolicited FETCH responses while (1) { my ($lVanished, $lModified, $rVanished, $rModified); @@ -845,31 +1038,33 @@ sub sync_known_messages($$) { 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 + $sth_get_remote_uid->bind_param(1, $idx, SQL_INTEGER); + $sth_get_remote_uid->bind_param(2, $lUID, SQL_INTEGER); + $sth_get_remote_uid->execute(); + my ($rUID) = $sth_get_remote_uid->fetchrow_array(); + die if defined $sth_get_remote_uid->fetch(); # safety check if (!defined $rUID) { push @lDunno, $lUID; - } - elsif (!exists $rVanished{$rUID}) { + } 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 + $sth_get_local_uid->bind_param(1, $idx, SQL_INTEGER); + $sth_get_local_uid->bind_param(2, $rUID, SQL_INTEGER); + $sth_get_local_uid->execute(); + my ($lUID) = $sth_get_local_uid->fetchrow_array(); + die if defined $sth_get_local_uid->fetch(); # safety check if (!defined $lUID) { push @rDunno, $rUID; - } - elsif (!exists $lVanished{$lUID}) { + } elsif (!exists $lVanished{$lUID}) { push @lToRemove, $lUID; } } - msg("remote($mailbox)", "WARNING: No match for ".($#lDunno+1)." vanished local UID(s) " + msg(fmt("remote(%r)",$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) " + msg(fmt("local(%l)",$mailbox), "WARNING: No match for ".($#rDunno+1)." vanished remote UID(s) " .compact_set(@rDunno).". Ignoring.") if @rDunno; $lIMAP->remove_message(@lToRemove) if @lToRemove; @@ -896,13 +1091,14 @@ sub sync_known_messages($$) { # 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 + $sth_get_remote_uid->bind_param(1, $idx, SQL_INTEGER); + $sth_get_remote_uid->bind_param(2, $lUID, SQL_INTEGER); + $sth_get_remote_uid->execute(); + my ($rUID) = $sth_get_remote_uid->fetchrow_array(); + die if defined $sth_get_remote_uid->fetch(); # safety check if (!defined $rUID) { - msg("remote($mailbox)", "WARNING: No match for modified local UID $lUID. Try '--repair'."); - } - elsif (defined (my $rFlags = $rModified->{$rUID})) { + msg(fmt("remote(%r)",$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} //= []; @@ -910,20 +1106,20 @@ sub sync_known_messages($$) { $rToUpdate{$flags} //= []; push @{$rToUpdate{$flags}}, $rUID; } - } - else { + } 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 + $sth_get_local_uid->bind_param(1, $idx, SQL_INTEGER); + $sth_get_local_uid->bind_param(2, $rUID, SQL_INTEGER); + $sth_get_local_uid->execute(); + my ($lUID) = $sth_get_local_uid->fetchrow_array(); + die if defined $sth_get_local_uid->fetch(); # safety check if (!defined $lUID) { - msg("local($mailbox)", "WARNING: No match for modified remote UID $rUID. Try '--repair'."); - } - elsif (!exists $lModified->{$lUID}) { + msg(fmt("local(%l)",$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; @@ -954,7 +1150,8 @@ sub callback_new_message($$$$;$$$) { my $length = length ${$mail->{RFC822}}; if ($length == 0) { - msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})"); + my $prefix = $name eq "local" ? "local(%l)" : "remote(%r)"; + msg(fmt($prefix, $mailbox), "WARNING: Ignoring new 0-length message (UID $mail->{UID})"); return; } @@ -983,16 +1180,23 @@ sub callback_new_message($$$$;$$$) { sub callback_new_message_flush($$$@) { my ($idx, $mailbox, $name, @messages) = @_; - my $imap = $name eq 'local' ? $rIMAP : $lIMAP; # target client + my $target = $name eq "local" ? "remote" : "local"; + my $imap = $target eq "local" ? $lIMAP : $rIMAP; # target client my @sUID = map {$_->{UID}} @messages; - my @tUID = $imap->append($mailbox, @messages); + my @tUID = $imap->append(mbx_name($target, $mailbox), @messages); die unless $#sUID == $#tUID; # sanity check + state $sth = $DBH->prepare(q{ + INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?) + }); 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") + logger(undef, fmt("Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for %d", $mailbox)) if $CONFIG{debug}; - $STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]); + $sth->bind_param(1, $idx, SQL_INTEGER); + $sth->bind_param(2, $lUIDs->[$k], SQL_INTEGER); + $sth->bind_param(3, $rUIDs->[$k], SQL_INTEGER); + $sth->execute(); } $DBH->commit(); # commit only once per batch @@ -1038,10 +1242,30 @@ sub sync_messages($$;$$) { # 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"); + + state $sth_update_local = $DBH->prepare(q{ + UPDATE local + SET UIDNEXT = ?, HIGHESTMODSEQ = ? + WHERE idx = ? + }); + state $sth_update_remote = $DBH->prepare(q{ + UPDATE remote + SET UIDNEXT = ?, HIGHESTMODSEQ = ? + WHERE idx = ? + }); + + my ($lUIDNEXT, $lHIGHESTMODSEQ) = $lIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/); + $sth_update_local->bind_param(1, $lUIDNEXT, SQL_INTEGER); + $sth_update_local->bind_param(2, sprintf("%lld", $lHIGHESTMODSEQ), SQL_BIGINT); + $sth_update_local->bind_param(3, $idx, SQL_INTEGER); + $sth_update_local->execute(); + + my ($rUIDNEXT, $rHIGHESTMODSEQ) = $rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/); + $sth_update_remote->bind_param(1, $rUIDNEXT, SQL_INTEGER); + $sth_update_remote->bind_param(2, sprintf("%lld", $rHIGHESTMODSEQ), SQL_BIGINT); + $sth_update_remote->bind_param(3, $idx, SQL_INTEGER); + $sth_update_remote->execute(); + $DBH->commit(); } @@ -1049,87 +1273,141 @@ sub sync_messages($$;$$) { ############################################################################# # 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) +my ($MAILBOX, $IDX); # current mailbox, and its index in our database + +sub db_get_cache_by_idx($) { + my $idx = shift; + state $sth = $DBH->prepare(q{ + SELECT 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 local l JOIN remote r ON l.idx = r.idx + WHERE l.idx = ? + }); + $sth->bind_param(1, $idx, SQL_INTEGER); + $sth->execute(); + my $cache = $sth->fetchrow_hashref(); + die if defined $sth->fetch(); # safety check + if (defined $cache) { + $cache->{$_} = sprintf("%llu", $cache->{$_}) foreach qw/lHIGHESTMODSEQ rHIGHESTMODSEQ/; } - die unless %lUIDs; # sanity check + return $cache; +} - $lIMAP->select($MAILBOX); - $rIMAP->select($MAILBOX); +{ + # Get the list of interrupted mailbox syncs. + my $sth_list = $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 + }); - # FETCH all messages with their FLAGS to detect messages that have - # vanished meanwhile, or for which there was a flag update. + # For an interrupted mailbox sync, get the pairs (lUID,rUID) that have + # already been downloaded. + my $sth_get_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 (lUID >= l.UIDNEXT OR rUID >= r.UIDNEXT) + AND m.idx = ? + }); - 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 }); + $sth_list->execute(); + while (defined (my $row = $sth_list->fetchrow_arrayref())) { + next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailboxes - 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}; + ($IDX, $MAILBOX) = @$row; + msg(undef, fmt("Resuming interrupted sync for %d", $MAILBOX)); + my $cache = db_get_cache_by_idx($IDX) // die; # safety check + my ($lMailbox, $rMailbox) = map {mbx_name($_, $MAILBOX)} qw/local remote/; - delete_mapping($IDX, $lUID); - } + my %lUIDs; + $sth_get_by_idx->bind_param(1, $IDX, SQL_INTEGER); + $sth_get_by_idx->execute(); + while (defined (my $row = $sth_get_by_idx->fetchrow_arrayref())) { + $lUIDs{$row->[0]} = $row->[1]; # pair ($lUID, $rUID) + } + die unless %lUIDs; # sanity check - $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.) - $STH_GET_CACHE_BY_IDX->execute($IDX); - if (defined (my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref())) { - $lIMAP->set_cache($cache->{mailbox}, + $lIMAP->select($lMailbox); + $rIMAP->select($rMailbox); + + # 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 = "(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.) + $lIMAP->set_cache($lMailbox, UIDVALIDITY => $cache->{lUIDVALIDITY}, UIDNEXT => $cache->{lUIDNEXT} ); - $rIMAP->set_cache($cache->{mailbox}, + $rIMAP->set_cache($rMailbox, UIDVALIDITY => $cache->{rUIDVALIDITY}, UIDNEXT => $cache->{rUIDNEXT} ); - die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check + sync_messages($IDX, $MAILBOX, [keys %lList], [keys %rList]); } - 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; +{ + # Get all cached states from the database. + my $sth = $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 + }); + + $sth->execute(); + while (defined (my $row = $sth->fetchrow_hashref())) { + next unless grep {$row->{mailbox} eq $_} @MAILBOXES; + $lIMAP->set_cache(mbx_name(local => $row->{mailbox}), + UIDVALIDITY => $row->{lUIDVALIDITY}, + UIDNEXT => $row->{lUIDNEXT}, + HIGHESTMODSEQ => sprintf("%llu", $row->{lHIGHESTMODSEQ}) + ); + $rIMAP->set_cache(mbx_name(remote => $row->{mailbox}), + UIDVALIDITY => $row->{rUIDVALIDITY}, + UIDNEXT => $row->{rUIDNEXT}, + HIGHESTMODSEQ => sprintf("%llu", $row->{rHIGHESTMODSEQ}) + ); + $KNOWN_INDEXES{$row->{idx}} = 1; + } } if (defined $COMMAND and $COMMAND eq 'repair') { @@ -1145,39 +1423,62 @@ if ($CONFIG{notify}) { # in batch mode, update the HIGHESTMODSEQ, and *then* issue an explicit UID # FETCH command to get new message, and process each FETCH response with a # RFC822/BODY[] attribute as they arrive. - my $mailboxes = join(' ', map {Net::IMAP::InterIMAP::quote($_)} @MAILBOXES); - my %mailboxes = map { $_ => [qw/MessageNew MessageExpunge FlagChange/] } - ( "MAILBOXES ($mailboxes)", 'SELECTED' ); - my %personal = ( personal => [qw/MailboxName SubscriptionChange/] ); + foreach my $name (qw/local remote/) { + my $mailboxes = join(' ', map {Net::IMAP::InterIMAP::quote(mbx_name($name, $_))} @MAILBOXES); + my %mailboxes = map { $_ => [qw/MessageNew MessageExpunge FlagChange/] } + ( "MAILBOXES ($mailboxes)", 'SELECTED' ); + my %personal = ( personal => [qw/MailboxName SubscriptionChange/] ); + my $imap = $name eq "local" ? $lIMAP : $rIMAP; - foreach ($lIMAP, $rIMAP) { # require STATUS responses for our @MAILBOXES only - $_->notify('SET STATUS', %mailboxes); - $_->notify('SET', %mailboxes, %personal); + $imap->notify('SET STATUS', %mailboxes); + $imap->notify('SET', %mailboxes, %personal); } } sub loop() { + state $sth_insert_local = $DBH->prepare(q{ + INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0) + }); + state $sth_insert_remote = $DBH->prepare(q{ + INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0) + }); + + state $sth_update_local_highestmodseq = $DBH->prepare(q{ + UPDATE local + SET HIGHESTMODSEQ = ? + WHERE idx = ? + }); + state $sth_update_remote_highestmodseq = $DBH->prepare(q{ + UPDATE remote + SET HIGHESTMODSEQ = ? + WHERE idx = ? + }); + while(@MAILBOXES) { - if (defined $MAILBOX and ($lIMAP->is_dirty($MAILBOX) or $rIMAP->is_dirty($MAILBOX))) { + if (defined $MAILBOX and ($lIMAP->is_dirty(mbx_name(local => $MAILBOX)) or $rIMAP->is_dirty(mbx_name(remote => $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; + $MAILBOX = mbx_unname(local => $lIMAP->next_dirty_mailbox(map {mbx_name(local => $_)} @MAILBOXES)) + // mbx_unname(remote => $rIMAP->next_dirty_mailbox(map {mbx_name(remote => $_)} @MAILBOXES)) + // last; + $IDX = db_get_mailbox_idx($MAILBOX) // die; # safety 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)); + my $lUIDVALIDITY = $lIMAP->uidvalidity(mbx_name(local => $MAILBOX)); + $sth_insert_local->bind_param(1, $IDX, SQL_INTEGER); + $sth_insert_local->bind_param(2, $lUIDVALIDITY, SQL_INTEGER); + $sth_insert_local->execute(); + + my $rUIDVALIDITY = $rIMAP->uidvalidity(mbx_name(remote => $MAILBOX)); + $sth_insert_remote->bind_param(1, $IDX, SQL_INTEGER); + $sth_insert_remote->bind_param(2, $rUIDVALIDITY, SQL_INTEGER); + $sth_insert_remote->execute(); # no need to commit before the first mapping (lUID,rUID) $KNOWN_INDEXES{$IDX} = 1; @@ -1185,10 +1486,15 @@ sub loop() { 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"); + my $lHIGHESTMODSEQ = sprintf "%lld", $lIMAP->get_cache(qw/HIGHESTMODSEQ/); + $sth_update_local_highestmodseq->bind_param(1, $lHIGHESTMODSEQ, SQL_BIGINT); + $sth_update_local_highestmodseq->bind_param(2, $IDX, SQL_INTEGER); + $sth_update_local_highestmodseq->execute(); + + my $rHIGHESTMODSEQ = sprintf "%lld", $rIMAP->get_cache(qw/HIGHESTMODSEQ/); + $sth_update_remote_highestmodseq->bind_param(1, $rHIGHESTMODSEQ, SQL_BIGINT); + $sth_update_remote_highestmodseq->bind_param(2, $IDX, SQL_INTEGER); + $sth_update_remote_highestmodseq->execute(); $DBH->commit(); } sync_messages($IDX, $MAILBOX); @@ -1242,7 +1548,7 @@ while (1) { sleep $CONFIG{watch}; # refresh the mailbox list and status - @{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/; + list_mailboxes($_) for qw/local remote/; @MAILBOXES = sync_mailbox_list(); } } |