path: root/lib/Net/IMAP/InterIMAP.pm

#----------------------------------------------------------------------
# A minimal IMAP4 client for QRESYNC-capable servers
# 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
# 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/>.
#----------------------------------------------------------------------

package Net::IMAP::InterIMAP v0.0.5;
use v5.20.0;
use warnings;
use strict;

use Compress::Raw::Zlib qw/Z_OK Z_STREAM_END Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
use Errno qw/EEXIST EINTR/;
use Net::SSLeay 1.83 ();
use List::Util qw/all first/;
use POSIX ':signal_h';
use Socket qw/SOCK_STREAM SOCK_RAW SOCK_CLOEXEC IPPROTO_TCP SHUT_RDWR
              AF_UNIX AF_INET AF_INET6 PF_UNSPEC :addrinfo/;

use Exporter 'import';
BEGIN {
    Net::SSLeay::load_error_strings();
    Net::SSLeay::SSLeay_add_ssl_algorithms();
    Net::SSLeay::randomize();

    our @EXPORT_OK = qw/xdg_basedir read_config compact_set
                        slurp is_dirty has_new_mails/;
}


# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR', 'list-char' and 'TEXT-CHAR'.
my $RE_ATOM_CHAR    = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/;
my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/;
my $RE_LIST_CHAR    = qr/[\x21\x23-\x27\x2A\x2B-\x5B\x5D-\x7A\x7C-\x7E]/;
my $RE_TEXT_CHAR    = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;

my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-3])/;

# Map each option to a regexp validating its values.
my %OPTIONS = (
    host => qr/\A(\P{Control}+)\z/,
    port => qr/\A(\P{Control}+)\z/,
    proxy => qr/\A(\P{Control}+)\z/,
    type => qr/\A(imaps?|tunnel)\z/,
    STARTTLS => qr/\A(YES|NO)\z/i,
    username => qr/\A([\x01-\x7F]+)\z/,
    password => qr/\A([\x01-\x7F]+)\z/,
    auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
    command => qr/\A(\P{Control}+)\z/,
    'null-stderr' => qr/\A(YES|NO)\z/i,
    compress => qr/\A(YES|NO)\z/i,
    SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/,
    SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+(?: (?:[A-Za-z0-9]+\$)?\p{AHex}+)*)\z/,
    SSL_cipherlist => qr/\A(\P{Control}+)\z/,
    SSL_verify => qr/\A(YES|NO)\z/i,
    SSL_CApath => qr/\A(\P{Control}+)\z/,
    SSL_CAfile => qr/\A(\P{Control}+)\z/,
);

# Use the same buffer size as Net::SSLeay::read(), to ensure there is
# never any pending data left in the current TLS record
my $BUFSIZE = 32768;
my $CRLF = "\x0D\x0A";

#############################################################################
# Utilities

# xdg_basedir($xdg_variable, $default, $subdir, $path)
#   Return $path if $path is absolute.  Otherwise, return
#   "$ENV{$xdg_variable}/$subdir/$path" (resp. "~/$default/$subdir/path"
#   if the "$xdg_variable" environment variable is not set).
#   An error is raised if "$ENV{$xdg_variable}" (resp. "~/$default") is
#   not an existing absolute directory.
#   If "$ENV{$xdg_variable}/$subdir" doesn't exist, it is created with
#   mode 0700.
sub xdg_basedir($$$$) {
    my ($xdg_variable, $default, $subdir, $path) = @_;
    $path =~ /\A(\p{Print}+)\z/ or die "Insecure $path";
    $path = $1;
    return $path if $path =~ /\A\//;

    my $basedir = $ENV{$xdg_variable};
    $basedir = ($ENV{HOME} // "") ."/". $default unless defined $basedir;
    die "No such directory: ", $basedir unless -d $basedir;

    $basedir .= "/".$subdir;
    $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir";
    $basedir = $1;
    unless (mkdir ($basedir, 0700)) {
        die "Couldn't create $basedir: $!\n" unless $! == EEXIST;
    }
    return $basedir ."/". $path;
}

# read_config($conffile, $sections, %opts)
#   Read $conffile's default section, then each section in the array
#   reference $section (which takes precedence).  %opts extends %OPTIONS
#   and maps each option to a regexp validating its values.
sub read_config($$%) {
    my $conffile = shift;
    my $sections = shift;
    my %opts = (%OPTIONS, @_);

    die "No such config file $conffile\n"
        unless defined $conffile and -f $conffile and -r $conffile;

    my $h = Config::Tiny::->read($conffile);

    my %configs;
    foreach my $section (@$sections) {
        my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section
        $configs{$section} = $conf;

        if ($section ne '_') {
            die "No such section $section\n" unless defined $h->{$section};
            $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
        }

        # default values
        $conf->{type} //= 'imaps';
        $conf->{host} //= 'localhost';
        $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef;
        $conf->{auth} //= 'PLAIN LOGIN';
        $conf->{STARTTLS} //= 'YES';

        # untaint and validate the config
        foreach my $k (keys %$conf) {
            die "Invalid option $k\n" unless defined $opts{$k};
            next unless defined $conf->{$k};
            die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
            $conf->{$k} = $opts{$k} ne qr/\A(YES|NO)\z/i ? $1 : uc $1 eq 'YES' ? 1 : 0;
        }
    }
    return \%configs;
}


# compact_set(@set)
# compact_list(@set)
#   Compact the UID or sequence number set @set, which must be
#   non-empty and may not contain '*'.
#   compact_set sorts the input UID list and removes duplicates, while
#   compact_list doesn't.
sub compact_set(@) {
    my @set = sort {$a <=> $b} @_;
    my $min = my $max = shift @set // die 'Empty range';
    my $set;

    while (@set) {
        my $k = shift @set;
        if ($k < $max) {
            die "Non-sorted range: $k < $max"; # sanity check
        }
        elsif ($k == $max) { # skip duplicates
        }
        elsif ($k == $max + 1) {
            $max++;
        }
        else {
            $set .= ',' if defined $set;
            $set .= $min == $max ? $min : "$min:$max";
            $min = $max = $k;
        }
    }

    $set .= ',' if defined $set;
    $set .= $min == $max ? $min : "$min:$max";
    return $set;
}
sub compact_list(@) {
    my $min = my $max = shift // die 'Empty range';
    my ($set, $dir);

    while (@_) {
        my $k = shift;
        $dir //= $k < $max ? -1 : 1;
        if ($k != $max and $k == $max + $dir) {
            $max += $dir;
        }
        else {
            $set .= ',' if defined $set;
            $set .= $min == $max ? $min : "$min:$max";
            $min = $max = $k;
            undef $dir;
        }
    }

    $set .= ',' if defined $set;
    $set .= $min == $max ? $min : "$min:$max";
    return $set;
}

# with_set($set, $cmd)
#   Split long commands over multiple subsets to avoid exceeding the server limit
sub with_set($&) {
    my ($set, $cmd) = @_;
    my $max_length = 4096;
    for (my $length = length($set); $length > $max_length;) {
        my $l = rindex($set, ',', $max_length);
        die unless $l > 0; # sanity check
        $cmd->(substr($set, 0, $l));
        $set = substr($set, ++$l);
        $length -= $l;
    }
    return $cmd->($set);
}


# in_set($x, $set)
#   Return true if the UID or sequence number $x belongs to the set $set.
#   /!\  The highest number in the mailbox, "*" should not appear by
#   itself (other than in a range).
sub in_set($$) {
    my ($x, $set) = @_;
    foreach my $r (split /,/, $set) {
        if ($r =~ /\A([0-9]+)\z/) {
            return 1 if $x == $1;
        }
        elsif ($r eq '*' or $r eq '*:*') {
            warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
            return 1;
        }
        elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) {
            return 1 if $1 <= $x;
        }
        elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) {
            my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1);
            return 1 if $min <= $x and $x <= $max;
        }
    }
    return 0;
}


# quote($str)
#   Quote the given string if needed, or make it a (synchronizing)
#   literal.  The literals will later be made non-synchronizing if the
#   server is LITERAL+-capable (RFC 2088).
sub quote($) {
    my $str = shift;
    if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) {
        return $str;
    }
    elsif ($str =~ qr/\A$RE_TEXT_CHAR*\z/) {
        $str =~ s/([\x22\x5C])/\\$1/g;
        return "\"$str\"";
    }
    else {
        # we'll later replace the non-synchronizing literal with a
        # synchronizing one if need be
        return "{".length($str)."+}$CRLF".$str;
    }
}



#############################################################################
# Public interface
# /!\ While this module can be used with non QRESYNC-capable (or non
# QRESYNC-enabled) servers, there is no internal cache mapping sequence
# numbers to UIDs, so EXPUNGE responses are ignored.

# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status
# ('OK'/'NO'/'BAD') condition for the last command issued.
our $IMAP_cond;

# The response text for the last command issued (prefixed with the status
# condition but without the tag).
our $IMAP_text;


# Create a new Net::IMAP::InterIMAP object.  Connect to the server,
# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and
# update the CAPABILITY list.
# In addition to the %OPTIONS above, valid parameters include:
#
#   - 'debug': Enable debug messages.
#
#   - 'enable': An extension or array reference of extensions to ENABLE
#     (RFC 5161) after entering AUTH state.  Croak if the server did not
#     advertise "ENABLE" in its CAPABILITY list or does not reply with
#     an untagged ENABLED response with all the given extensions.
#
#   - 'name': An optional instance name to include in log messages.
#
#   - 'logger-fd': An optional filehandle to use for debug output
#     (default: STDERR).
#
#   - 'keepalive': Whether to enable sending of keep-alive messages.
#     (type=imap or type=imaps).
#
sub new($%) {
    my $class = shift;
    my $self = { @_ };
    bless $self, $class;
    require 'Time/HiRes.pm' if defined $self->{'logger-fd'};

    # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
    # (cf RFC 3501 section 3)
    $self->{_STATE} = '';

    # in/out buffer counts and output stream
    $self->{_INCOUNT}  = $self->{_INRAWCOUNT}  = 0;
    $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
    $self->{_OUTBUF} = $self->{_INBUF} = undef;
    $self->{_LITPLUS} = '';

    if ($self->{type} eq 'tunnel') {
        my $command = $self->{command} // $self->fail("Missing tunnel command");
        socketpair($self->{S}, my $s, AF_UNIX, SOCK_STREAM|SOCK_CLOEXEC, PF_UNSPEC) or $self->panic("socketpair: $!");
        my $pid = fork // $self->panic("fork: $!");
        unless ($pid) {
            # children
            close($self->{S}) or $self->panic("Can't close: $!");
            open STDIN,  '<&', $s or $self->panic("Can't dup: $!");
            open STDOUT, '>&', $s or $self->panic("Can't dup: $!");

            my $stderr2;
            if (($self->{'null-stderr'} // 0) and !($self->{debug} // 0)) {
                open $stderr2, '>&', *STDERR;
                open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!");
            }

            my $sigset = POSIX::SigSet::->new(SIGINT);
            my $oldsigset = POSIX::SigSet::->new();
            sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("Can't block SIGINT: $!");

            unless (exec $command) {
                my $err = $!;
                if (defined $stderr2) {
                    close STDERR;
                    open STDERR, '>&', $stderr2;
                }
                $self->panic("Can't exec: $err");
            }
        }

        # parent
        close($s) or $self->panic("Can't close: $!");
    }
    else {
        foreach (qw/host port/) {
            $self->fail("Missing option $_") unless defined $self->{$_};
        }
        $self->{S} = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/})
                                            : $self->_tcp_connect(@$self{qw/host port/});
        if (defined $self->{keepalive}) {
            setsockopt($self->{S}, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1)
                or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
            setsockopt($self->{S}, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60)
                or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!");
        }

    }
    binmode($self->{S}) // $self->panic("binmode: $!");
    $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps';

    # command counter
    $self->{_TAG} = 0;

    # internal cache, constantly updated to reflect the current server
    # state for each mailbox
    $self->{_CACHE} = {};

    # persistent cache, describing the last clean (synced) state
    $self->{_PCACHE} = {};

    # list of UIDs for which the server a VANISHED or VANISHED (EARLIER)
    # response.  /!\ requires a QRESYNC-capable server!
    # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
    # are considered.
    $self->{_VANISHED} = [];

    # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH
    # response with the FLAGS attribute.  The \Recent flag is always
    # omitted from the FLAG list.  MODSEQ is always present, and the
    # value [ MODSEQ, FLAGS ] is updated if another FETCH response with
    # a higher MODSEQ is received.  If FLAGS is undefined, then the FLAG
    # list of the message is considered unknown and should be retrieved
    # manually.
    # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
    # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ}
    # are considered.
    $self->{_MODIFIED} = {};

    # wait for the greeting
    my $x = $self->_getline();
    $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x);
    $IMAP_cond = $1;
    $IMAP_text = $1.' '.$x;

    # try to update the cache (eg, capabilities)
    $self->_resp_text($x);

    if ($IMAP_cond eq 'OK') {
        # login required
        $self->{_STATE} = 'UNAUTH';
        my @caps = $self->capabilities();

        if ($self->{type} eq 'imap' and $self->{STARTTLS}) { # RFC 2595 section 5.1
            $self->fail("Server did not advertise STARTTLS capability.")
                unless grep {$_ eq 'STARTTLS'} @caps;
            $self->_send('STARTTLS');
            $self->_start_ssl($self->{S});

            # refresh the previous CAPABILITY list since the previous one could have been spoofed
            delete $self->{_CAPABILITIES};
            @caps = $self->capabilities();
        }

        my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? uc($1) : undef } @caps);
        my $mech = (grep defined, map {my $m = uc($_); (grep {$m eq $_} @mechs) ? $m : undef}
                                      split(/ /, $self->{auth}))[0];
        $self->fail("Failed to choose an authentication mechanism") unless defined $mech;
        $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and
                                               grep {$_ eq 'LOGINDISABLED'} @caps;

        my ($command, $callback);
        my ($username, $password) = @$self{qw/username password/};

        if ($mech eq 'LOGIN') {
            $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
            $command = join ' ', 'LOGIN', quote($username), quote($password);
        }
        elsif ($mech eq 'PLAIN') {
            require 'MIME/Base64.pm';
            $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
            my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, '');
            $command = "AUTHENTICATE $mech";
            if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR
                $command .= " $credentials";
            } else {
                $callback = sub($) {return $credentials};
            }
        }
        else {
            $self->fail("Unsupported authentication mechanism: $mech");
        }

        my $dbg;
        delete $self->{password}; # no need to remember passwords
        if (($self->{debug} // 0) == 1) {
            $dbg = $self->{debug}--;
            my $cmd = $command =~ /\A(LOGIN) / ? $1
                    : $command =~ /\A(AUTHENTICATE \S+)(?: .*)?\z/ ? $1
                    : $self->panic();
            $self->logger('C: xxx ', $cmd, ' [REDACTED]');
        }
        $self->_se