diff options
Diffstat (limited to 'interimap')
| -rwxr-xr-x | interimap | 1016 |
1 files changed, 596 insertions, 420 deletions
@@ -24,9 +24,10 @@ use warnings; 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'; @@ -154,8 +155,7 @@ $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; @@ -171,63 +171,10 @@ $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->do("PRAGMA foreign_keys = ON"); } sub msg($@) { @@ -280,21 +227,52 @@ foreach my $name (qw/local remote/) { # Pretty-print hierarchy delimiter: DQUOTE QUOTED-CHAR DQUOTE / nil sub print_delimiter($) { my $d = shift // return "NIL"; - $d =~ s/([\x22\x5C])/\\$1/g; + $d = "\\".$d if $d eq "\\" or $d eq "\""; return "\"".$d."\""; } +# Return the delimiter of the default namespace, 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) = @_; + + # Use the cached value if present + return $imap->{delimiter} if exists $imap->{delimiter}; + + my (undef, $d) = $imap->{client}->list("\"\" \"\""); + 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. + 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 $list = ""; $list .= "(" .$LIST{'select-opts'}. ") " if defined $LIST{'select-opts'}; $list .= "\"\" "; - $list .= $#{$LIST{mailbox}} < 0 ? "*" - : $#{$LIST{mailbox}} == 0 ? Net::IMAP::InterIMAP::quote($LIST{mailbox}->[0]) - : "(".join(" ", map {Net::IMAP::InterIMAP::quote($_)} @{$LIST{mailbox}}).")"; - my ($mbx, $delims) = $IMAP->{$name}->{client}->list($list, @{$LIST{params} // []}); - $IMAP->{$name}->{mailboxes} = $mbx; + + 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) // + 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 @@ -303,32 +281,26 @@ sub list_mailboxes($) { # the user needs to start multiple interimap instances.) delete $delims->{INBOX}; - unless (exists $IMAP->{$name}->{delimiter}) { - # Nothing to do if we already cached the hierarchy delimiter. + 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. + # got a non-INBOX LIST reply, use the first one as authoritative value my ($m) = sort keys %$delims; - $IMAP->{$name}->{delimiter} = delete $delims->{$m}; + $imap->{delimiter} = delete $delims->{$m}; } else { - # Didn't get a non-INBOX LIST reply so we issue a new LIST command - # with the empty mailbox to get the delimiter of the default namespace. - my (undef, $d) = $IMAP->{$name}->{client}->list("\"\" \"\""); - 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. - fail($name, "Missing or unexpected (unsolicited) LIST response.") - unless $#d == 0; - $IMAP->{$name}->{delimiter} = $d[0]; + # didn't get a non-INBOX LIST reply so we need to explicitely query + # the hierarchy delimiter + get_delimiter($name, $imap); } - logger($name, "Using ", print_delimiter($IMAP->{$name}->{delimiter}), - " as hierarchy delimiter") if $CONFIG{debug}; } + 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. - my $d = $IMAP->{$name}->{delimiter}; + 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.") @@ -337,34 +309,197 @@ sub list_mailboxes($) { } } -list_mailboxes($_) for qw/local remote/; +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}; + -# Ensure local and remote hierarchy delimiters match. -# XXX There is no real reason to enforce that. We could for instance -# use NUL bytes in the database and config, and substitute it with the -# local/remote delimiter on the fly. -fail (undef, "Local and remote hiearchy delimiters differ: ", - print_delimiter($IMAP->{local}->{delimiter}), " != ", - print_delimiter($IMAP->{remote}->{delimiter}), ".") - if (defined $IMAP->{local}->{delimiter} xor defined $IMAP->{remote}->{delimiter}) - or (defined $IMAP->{local}->{delimiter} and defined $IMAP->{remote}->{delimiter} - and $IMAP->{local}->{delimiter} ne $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 + # 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 + # 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 + 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("PRAGMA foreign_keys = OFF"); + $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"); + $DBH->do("PRAGMA foreign_keys = ON"); + } + SCHEMA_DONE: + $DBH->do("PRAGMA user_version = $DATABASE_VERSION"); + $DBH->commit(); + } +} ############################################################################## # # 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 = ?}); +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) +# to a name understandable by the local/remote IMAP server. +sub mbx_name($$) { + my ($name, $mailbox) = @_; + my $x = $name // "local"; + 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 $mailbox; +} + +# Transform mailbox name from local/remote IMAP server to the internal representation +# (with \0 as hierarchy delimiters). +sub mbx_unname($$) { + my ($name, $mailbox) = @_; + return unless defined $mailbox; + + 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 @@ -379,36 +514,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 unless $CONFIG{target}->{$name}; - $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 $CONFIG{target}->{database}) { - 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; - + 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; @@ -420,55 +552,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 + 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 unless $CONFIG{target}->{$name}; - fail($name, "Mailbox $to exists. Run `$NAME --target=$name --delete $to` to delete.") - if mbx_exists($name, $to); + 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); - fail("database", "Mailbox $to exists. Run `$NAME --target=database --delete $to` to delete.") - if defined $STH_GET_INDEX->fetch() and $CONFIG{target}->{database}; + 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 unless $CONFIG{target}->{$name}; - $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from); + 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 $CONFIG{target}->{database}) { - 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 - # (we made sure the local and remote delimiters were identical already) - if (defined (my $delim = $IMAP->{local}->{delimiter})) { - 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; } @@ -479,8 +622,14 @@ elsif (defined $COMMAND and $COMMAND eq 'rename') { sub sync_mailbox_list() { my (%mailboxes, @mailboxes); + 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}}) { + $mbx = mbx_unname($name, $mbx); + # 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"} @@ -489,116 +638,78 @@ sub sync_mailbox_list() { } } - my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); - foreach my $mailbox (keys %mailboxes) { - 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; - }; - - 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 - fail("database", "Mailbox $mailbox exists. Run `$NAME --target=database --delete $mailbox` to delete.") + 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 $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 - fail("database", "Mailbox $mailbox exists. Run `$NAME --target=database --delete $mailbox` to delete.") - if defined $idx; - 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; + 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 = ?}); @@ -611,34 +722,6 @@ my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMO 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 new allocated UIDs sub download_missing($$$@) { my $idx = shift; @@ -647,22 +730,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; @@ -676,18 +759,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; } @@ -699,25 +788,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 : ''); @@ -730,9 +817,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 ); } @@ -741,12 +829,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)); } @@ -754,59 +863,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} //= []; @@ -816,17 +922,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; } } @@ -835,7 +940,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; } } @@ -862,21 +967,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; } @@ -897,7 +1001,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); @@ -920,31 +1036,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; @@ -971,13 +1089,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} //= []; @@ -985,20 +1104,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; @@ -1029,7 +1148,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; } @@ -1058,16 +1178,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 @@ -1124,87 +1251,138 @@ 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) - } - die unless %lUIDs; # sanity check +my ($MAILBOX, $IDX); # current mailbox, and its index in our database - $lIMAP->select($MAILBOX); - $rIMAP->select($MAILBOX); +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 + return $cache; +} - # FETCH all messages with their FLAGS to detect messages that have - # vanished meanwhile, or for which there was a flag update. +{ + # 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 + }); - 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 }); + # 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 (@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}; + $sth_list->execute(); + while (defined (my $row = $sth_list->fetchrow_arrayref())) { + next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailboxes - delete_mapping($IDX, $lUID); - } + ($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/; - $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}, + 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->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 => $row->{lHIGHESTMODSEQ} + ); + $rIMAP->set_cache(mbx_name(remote => $row->{mailbox}), + UIDVALIDITY => $row->{rUIDVALIDITY}, + UIDNEXT => $row->{rUIDNEXT}, + HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ} + ); + $KNOWN_INDEXES{$row->{idx}} = 1; + } } if (defined $COMMAND and $COMMAND eq 'repair') { @@ -1220,34 +1398,32 @@ 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() { 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}) { |