path: root/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm

package JWebmail::Model::ReadMails::QMailAuthuser;

use v5.24;
use warnings;
use utf8;

use JWebmail::Config 'MAILDIR_EXTRACTOR';

use IPC::Open2;
use JSON::PP 'decode_json';
use Params::Check 'check';
use Role::Tiny::With;
use Scalar::Util 'blessed';
use namespace::clean;


with 'JWebmail::Model::ReadMails::Role';


package JWebmail::Model::ReadMails::QMailAuthuser::Error {

    use Data::Dumper 'Dumper';

    use overload
        '""' => \&to_string,
        bool => sub {1};

    sub new {
        my $cls = shift;
        my $msg = shift;
        my $self = {message => $msg};

        $self->{data} = $_[0] if @_ == 1;
        $self->{data} = [@_] if @_ > 1;

        return bless $self, $cls;
    }

    sub to_string {
        my $self = shift;
        my $verbose = 1; #shift;

        if ($verbose && defined $self->{data}) {
            my $errstr = Data::Dumper->new([$self->{data}])->Terse(1)->Indent(0)->Quotekeys(0)->Dump;
            return "$self->{message}: $errstr";
        }
        else {
            return $self->{message};
        }
    }

    sub throw {
        my $cls = shift;
        my $msg = shift;

        my $self = $cls->new($msg, @_);
        $self->_trace;

        die $self;
    }

    # taken from Mojo::Exception
    sub _trace {
        my ($self, $start) = (shift, shift // 1);
        my @frames;
        while (my @trace = caller($start++)) { push @frames, \@trace }
        $self->{frames} = \@frames;
    }

    sub message { shift->{message} }
    sub data { shift->{data} }
    sub frames { shift->{frames} }

}


my $QMailAuthuserCheck = {
    virtual_user  => {required => 1},
    mailbox_path  => {required => 1},
    authenticator => {required => 1},
};

sub new {
    my $cls = shift;
    my $self = @_ == 1 ? $_[0] : {@_};

    if (my $pkg = blessed $cls) {
        $self = {%$cls, %$self};
        $cls = $pkg;
    }
    local $Params::Check::ALLOW_UNKNOWN = 1;
    local $Params::Check::ONLY_ALLOW_DEFINED = 1;
    local $Params::Check::WARNINGS_FATAL = 1;
    my $s = check($QMailAuthuserCheck, $self)
        or die __PACKAGE__ . " creation failed!";
    $s->{prog} = MAILDIR_EXTRACTOR;
    return bless $s, $cls;
}


sub verify_user {
    my $self = shift;
    my $auth = shift;

    return eval { $self->build_and_run($auth, 'auth'); 1 }
        || do {
            my $e = $@;
            my $rc = eval { $e->data->{return_code} };
            if ($rc == 1) {
                return '';
            }
            else {
                die $e;
            }
        };
}

sub read_headers_for {
    my $self = shift;
    my $auth = shift;

    my %h = @_;
    my ($folder, $start, $end, $sort) = @h{qw(folder start end sort)};

    return $self->build_and_run($auth, 'list', [$folder, $start, $end, $sort]);
}

sub count {
    my $self = shift;
    my ($auth, $folder) = @_;

    return $self->build_and_run($auth, 'count', [$folder]);
}

sub show {
    my $self = shift;
    my ($auth, $folder, $mid) = @_;

    return $self->build_and_run($auth, 'read', [$folder, $mid]);
}

sub raw {
    my $self = shift;
    my ($auth, $folder, $mid, $path) = @_;

    return $self->build_and_run($auth, 'raw', [$folder, $mid, $path//'']);
}

sub search {
    my $self = shift;
    my ($auth, $pattern, $folder) = @_;

    return $self->build_and_run($auth, 'search', [$pattern, $folder]);
}

sub folders {
    my $self = shift;
    my ($auth) = @_;

    my $res = $self->build_and_run($auth, 'folders');
    unshift @$res, '' if ref $res eq 'ARRAY';
    return $res;
}

sub move {
    my $self = shift;
    my ($auth, $mid, $from_f, $to_f) = @_;

    my $_resp = $self->build_and_run($auth, 'move', [$mid, $from_f, $to_f]);
    return 1;
}


sub build_arg {
    my $self = shift;
    my ($user_mail_addr, $mode, $args) = @_;

    return $self->{authenticator} . ' true 3<&0'
        if $mode eq 'auth';

    my ($user_name) = $user_mail_addr =~ /(\w*)@/;

    return $self->{authenticator} . ' '
    . join(' ', map { my $x = s/(['\\])/\\$1/gr; "'$x'" } ($self->{prog}, $self->{mailbox_path}, $self->{virtual_user}, $user_name, $mode, @$args))
    . ' 3<&0';
}

sub start_qmauth {
    my $self = shift;
    my ($auth, $mode, $args) = @_;

    my $exec = $self->build_arg($auth->{user}, $mode, $args);

    my $pid = open2(my $reader, my $writer, $exec)
        or die "failed to create subprocess: $!";

    my $challenge = $auth->{challenge} || '';
    $writer->print("$auth->{user}\0$auth->{password}\0$challenge\0")
        or die "pipe wite failed: $!";
    close $writer
        or die "closing write pipe failed: $!";

    return $pid, $reader;
}

sub read_qmauth {
    my $_self = shift;
    my ($pid, $reader) = @_;

    my $input = <$reader>;

    my $rs;
    if (eof $reader) {
        # for IPC::Open2
        if (waitpid($pid, 0) == $pid) {
            $rs = $?;
        }
    }

    my ($resp, $rc);
    if (!defined $rs) {
        my ($r, $e);
        eval { $r = decode_json $input; 1 }
            or do {
                $rc = 6;
                $e = "$@";
            };
        $reader->read(my $buf, 32 * 1024**2);
        if (!eof $reader) {
            die 'mailpart too large (>32MB)';
            kill 'TERM', $pid;
        }
        close $reader;
        waitpid $pid, 0;
        $resp = {
            head => $r,
            body => $buf,
            rc => $?,
            e => $e,
        };
    }
    elsif ($rs == 3 << 8 || $rs == 0) {
        $rc = $rs >> 8;
        eval { $resp = decode_json $input if $input; 1 }
            or do {
                $resp = {
                    info => "error decoding response",
                    response => $input,
                    cause => $@,
                    return_code => $rc,
                };
            };
    }
    else {
        $rc = $rs >> 8;
        $resp = {
            info        => "got unsuccessful return code by qmail-authuser",
            return_code => $rc,
            response    => $input,
        };
    }

    return ($resp, $rc);
}

sub build_and_run {
    my $self = shift;
    my ($auth, $mode, $args) = @_;

    my @exec = $self->start_qmauth($auth, $mode, $args||[]);
    my ($resp, $rc) = $self->read_qmauth(@exec);

    if ($rc) {
        JWebmail::Model::ReadMails::QMailAuthuser::Error->throw(
            "qmail-authuser connection error", $resp);
    }
    return $resp;
}


1

__END__

=encoding utf-8

=head1 NAME

QMailAuthuser

=head1 SYNOPSIS

    ...

=head1 DESCRIPTION

This ReadMails driver starts and communicates with L<JWebmail::Model::Driver::QMailAuthuser::Extract> over qmail-authuser.
The Extract programm runs with elevated priviliges to be able to read and modify mailboxes.

=head1 ATTRIBUTES

=head2 qmail_dir

The parent directory of the bin directory where all qmail executables live.
Default C</var/qmail/>.

=head2 prog

The path to the extractor programm.
Default is the location of L<JWebmail::Model::Driver::QMailAuthuser::Extract> package.

=head2 logfile

A path to a log file that the extractor logs to.
Default '/dev/null' but highly recommended to set a real one.
Keep in mind that a different user need to be able to write to it.

=head1 METHODS

=head2 communicate

Arguments:

=over 6

=item mode

=item args

Depends on the mode

=item user

E-Mail address of the user

=item password

Corresponding e-mail user password

=item challenge

Challenge when using cram

=back

=head1 SEE ALSO

L<JWebmail::Model::ReadMails>, L<JWebmail::Model::Driver::QMailAuthuser::Extract>