Refactored ReadMails into a role

1 files changed, 267 insertions, 0 deletions

diff --git a/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
new file mode 100644
index 0000000..8387217
--- /dev/null
+++ b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
@@ -0,0 +1,267 @@
+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