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

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

use v5.22;
use warnings;
use utf8;

use File::Basename 'fileparse';
use IPC::Open2;
use JSON::PP 'decode_json';
use Params::Check 'check';
use Scalar::Util 'blessed';
use Role::Tiny::With;
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 = 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;

        die $cls->new($msg, @_)->_trace;
    }

    # 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 = {
    user      => {defined => 1, required => 1},
    maildir   => {defined => 1, required => 1},
    prog      => {defined => 1, required => 1},
    prefix    => {defined => 1, default => ''},
    qmail_dir => {defined => 1, default => '/var/qmail/'},
    logfile   => {defined => 1, default => '/dev/null'},
};

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

    if (my $pkg = blessed $cls) {
        $self = {%$cls, %$self};
        $cls = $pkg;
    }
    $self = check($QMailAuthuserCheck, $self, 1) || die;
    return bless $self, $cls;
}


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

    eval { $self->build_and_run($auth, 'auth'); 1 }
        or 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', [$start, $end, $sort, $folder]);
}

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

    my $resp = $self->build_and_run($auth, 'count', [$folder]);
    return ($resp->{size}, $resp->{count}, $resp->{new});
}

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

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

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) = @_;

    return $self->build_and_run($auth, 'folders');
}

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

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


sub build_arg {
    my $self = shift;
    my $user_mail_addr = shift;
    my $mode = shift;
    my $args = shift || [];

    return $self->{qmail_dir} . "/bin/qmail-authuser true 3<&0"
        if $mode eq 'auth';

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

    return $self->{qmail_dir}.'/bin/qmail-authuser'
    . $self->{prefix} . ' '
    . join(' ', map { my $x = s/(['\\])/\\$1/gr; "'$x'" } ($self->{prog}, $self->{maildir}, $self->{user}, $user_name, $mode, @$args))
    . ' 3<&0'
    . ' 2>>'.$self->{logfile};
}

sub execute {
    my $_self = shift;
    my $auth = shift;
    my $exec = shift;

    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';

    binmode $reader, ':encoding(UTF-8)';
    my $input = <$reader>;
    close $reader # waits for the child to finish
        or die 'closing read pipe failed';

    my $rc = $? >> 8;

    my $resp;
    if ($rc == 3 || $rc == 0) {
        eval { $resp = decode_json $input; 1 }
            or $resp = {info => "error decoding response", response => $input, cause => $@, return_code => $rc};
    }
    elsif ($rc) {
        $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 = shift;
    my $mode = shift;
    my $args = shift;

    my $exec = $self->build_arg($auth->{user}, $mode, $args);
    my ($resp, $rc) = $self->execute($auth, $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>

=cut