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

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

use v5.22;
use warnings;
use utf8;

use IPC::Open2;
use File::Basename 'fileparse';
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';


my $QMailAuthuserCheck = {
    user      => {defined => 1, required => 1},
    maildir   => {defined => 1, required => 1},
    prefix    => {defined => 1, default => ''},
    qmail_dir => {defined => 1, default => '/var/qmail/'},
    logfile   => {defined => 1, default => '/dev/null'},
    prog      => {defined => 1, default => ([fileparse(__FILE__)]->[1] . '/QMailAuthuser/Extract.pm')},
};

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;

    return !scalar $self->communicate(
        user => $auth->{user},
        password => $auth->{password},
        challenge => $auth->{challenge},
        mode => 'auth',
    )
}

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

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

    my ($resp, $rc) = $self->communicate(
        user => $auth->{user},
        password => $auth->{password},
        challenge => $auth->{challenge},
        mode => 'list',
        args => [$start // 0, $end // 0, $sort // 'date', $folder // ''],
    );
    die "connection error: $resp->{error}" if $rc;
    return $resp;
}

sub count {
    my $self = shift;

    my ($auth, $folder) = @_;

    my ($resp, $rc) = $self->communicate(
        user      => $auth->{user},
        password  => $auth->{password},
        challenge => $auth->{challenge},
        mode      => 'count',
        args      => [$folder],
    );
    die "connection error: $resp->{error}" if $rc;
    return ($resp->{size}, $resp->{count}, $resp->{new});
}

sub show {
    my $self = shift;

    my ($auth, $mid) = @_;

    my ($resp, $rc) = $self->communicate(
        user => $auth->{user},
        password => $auth->{password},
        challenge => $auth->{challenge},
        mode => 'read-mail',
        args => [$mid],
    );
    die "connection error: $resp->{error}, $resp->{mid}" if $rc;
    return $resp;
}

sub search {
    my $self = shift;

    my ($auth, $pattern, $folder) = @_;

    my ($resp, $rc) = $self->communicate(
        user => $auth->{user},
        password => $auth->{password},
        challenge => $auth->{challenge},
        mode => 'search',
        args => [$pattern, $folder],
    );
    die "connection error: $resp->{error}" if $rc;
    return $resp;
}

sub folders {
    my $self = shift;

    my ($auth) = @_;

    my ($resp, $rc) = $self->communicate(
        user => $auth->{user},
        password => $auth->{password},
        challenge => $auth->{challenge},
        mode => 'folders',
    );
    die "connection error: $resp->{error}" if $rc;
    return $resp;
}

sub move {
    my $self = shift;

    my ($auth, $mid, $folder) = @_;

    my ($resp, $rc) = $self->communicate(
        user => $auth->{user},
        password => $auth->{password},
        challenge => $auth->{challenge},
        mode => 'move',
        args => [$mid, $folder],
    );
    die "connection error: $resp->{error}" if $rc;
    return 1;
}

sub communicate {
    my $self = shift;
    my %args = @_;

    $args{challenge} //= '';
    $args{args} //= [];

    my $exec = do {
        if ($args{mode} eq 'auth') {
            $self->{qmail_dir} . "/bin/qmail-authuser true 3<&0";
        }
        else {
            my ($user_name) = $args{user} =~ /(\w*)@/;

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

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

    $writer->print("$args{user}\0$args{password}\0$args{challenge}\0")
        or die 'pipe wite failed';
    close $writer
        or die 'closing write pipe failed';

    binmode $reader, ':utf8';
    my $input = <$reader>;
    close $reader
        or die 'closing read pipe failed';

    waitpid($pid, 0);
    my $rc = $? >> 8;

    my $resp;
    if ($rc == 3 || $rc == 0) {
        eval { $resp = decode_json $input; };
        if ($@) { $resp = {error => 'decoding error'} };
    }
    elsif ($rc) {
        $resp = {error => "qmail-authuser returned code: $rc"};
    }

    return ($resp, $rc);
}

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