path: root/interimap

#!/usr/bin/perl -T

#----------------------------------------------------------------------
# Fast bidirectional synchronization for QRESYNC-capable IMAP servers
# Copyright © 2015-2022 Guilhem Moulin <guilhem@fripost.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.
#----------------------------------------------------------------------

use v5.14.2;
use strict;
use warnings;

our $VERSION = '0.5.7';
my $NAME = 'interimap';
my $DATABASE_VERSION = 1;
use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
                            bundling auto_version/;
use DBI ':sql_types';
use DBD::SQLite::Constants ':file_open';
use Fcntl qw/O_WRONLY O_CREAT O_EXCL F_GETFD F_SETFD FD_CLOEXEC/;
use List::Util 'first';

use lib "./lib";
use Net::IMAP::InterIMAP 0.5.7 qw/xdg_basedir read_config compact_set/;

# Clean up PATH
$ENV{PATH} = join ':', qw{/usr/bin /bin};
delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};

my %CONFIG;
sub usage(;$) {
    my $rv = shift // 0;
    if ($rv) {
        print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n"
                    ."Try '$NAME --help' or consult the manpage for more information.\n";
    }
    else {
        print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n"
                    ."  or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n"
                    ."  or: $NAME [OPTIONS] --delete MAILBOX [..]\n"
                    ."  or: $NAME [OPTIONS] --rename SOURCE DEST\n"
                    ."Consult the manpage for more information.\n";
    }
    exit $rv;
}

my @COMMANDS = qw/repair delete rename/;
usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug+ help|h watch:i notify/, @COMMANDS);
usage(0) if $CONFIG{help};
my $COMMAND = do {
    my @command = grep {exists $CONFIG{$_}} @COMMANDS;
    usage(1) if $#command>0;
    $command[0]
};
usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or ($COMMAND eq 'rename' and $#ARGV != 1));
usage(1) if defined $COMMAND and (defined $CONFIG{watch} or defined $CONFIG{notify});
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;


my $CONF = do {
    my $conffile = delete($CONFIG{config}) // "config";
    $conffile = xdg_basedir( XDG_CONFIG_HOME => ".config", $NAME, $conffile );
    read_config( $conffile
               , [qw/_ local remote/]
               , database => qr/\A(\P{Control}+)\z/
               , logfile => qr/\A(\/\P{Control}+)\z/
               , 'log-prefix' => 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([\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_CONF, %LIST);

{
    $CONF->{_} //= {};
    $DBFILE = $CONF->{_}->{database};
    $DBFILE //= $CONF->{remote}->{host}.'.db' if defined $CONF->{remote};
    $DBFILE //= $CONF->{local}->{host}. '.db' if defined $CONF->{local};
    die "Missing option database" unless defined $DBFILE;
    $DBFILE = xdg_basedir( XDG_DATA_HOME => ".local/share", $NAME, $DBFILE );

    $LOGGER_CONF{'logger-prefix'} = $CONF->{_}->{'log-prefix'} // "%?n?%?m?%n(%m)&%n?: ?";
    if (defined (my $l = $CONF->{_}->{logfile})) {
        require 'POSIX.pm';
        require 'Time/HiRes.pm';
        open my $fd, '>>', $l or die "Can't open $l: $!\n";
        $fd->autoflush(1);
        my $flags = fcntl($fd, F_GETFD, 0)       or die "fcntl F_GETFD: $!";
        fcntl($fd, F_SETFD, $flags | FD_CLOEXEC) or die "fcntl F_SETFD: $!";
        $LOGGER_CONF{'logger-fd'} = $fd;
    }

    $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