adjusted QMailAuthuser to ReadMails Role

1 files changed, 114 insertions, 85 deletions

diff --git a/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
index 8387217..09b8b9d 100644
--- a/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
+++ b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
@@ -4,8 +4,8 @@ use v5.22;
 use warnings;
 use utf8;
 
-use IPC::Open2;
 use File::Basename 'fileparse';
+use IPC::Open2;
 use JSON::PP 'decode_json';
 use Params::Check 'check';
 use Scalar::Util 'blessed';
@@ -15,13 +15,67 @@ 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;
+    }
+
+    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'},
-    prog      => {defined => 1, default => ([fileparse(__FILE__)]->[1] . '/QMailAuthuser/Extract.pm')},
 };
 
 sub new {
@@ -36,16 +90,22 @@ sub new {
     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',
-    )
+    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 {
@@ -55,122 +115,75 @@ sub read_headers_for {
     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;
+    return $self->build_and_run($auth, 'list', [$start, $end, $sort, $folder]);
 }
 
 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;
+    my $resp = $self->build_and_run($auth, 'count', [$folder]);
     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;
+    return $self->build_and_run($auth, 'read-mail', [$mid]);
 }
 
 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;
+    return $self->build_and_run($auth, 'search', [$pattern, $folder]);
 }
 
 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;
+    return $self->build_and_run($auth, 'folders');
 }
 
 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;
+    my $_resp = $self->build_and_run($auth, 'move', [$mid, $folder]);
     return 1;
 }
 
-sub communicate {
+
+sub build_arg {
     my $self = shift;
-    my %args = @_;
+    my $user_mail_addr = shift;
+    my $mode = shift;
+    my $args = shift || [];
 
-    $args{challenge} //= '';
-    $args{args} //= [];
+    return $self->{qmail_dir} . "/bin/qmail-authuser true 3<&0"
+        if $mode eq 'auth';
 
-    my $exec = do {
-        if ($args{mode} eq 'auth') {
-            $self->{qmail_dir} . "/bin/qmail-authuser true 3<&0";
-        }
-        else {
-            my ($user_name) = $args{user} =~ /(\w*)@/;
+    my ($user_name) = $user_mail_addr =~ /(\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};
-        }
-    };
+    return $self->{qmail_dir}.'/bin/qmail-authuser'
+    . $self->{prefix} . ' '
+    . join(' ', map { s/(['\\])/\\$1/g; "'$_'" } ($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';
 
-    $writer->print("$args{user}\0$args{password}\0$args{challenge}\0")
+    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';
@@ -185,16 +198,32 @@ sub communicate {
 
     my $resp;
     if ($rc == 3 || $rc == 0) {
-        eval { $resp = decode_json $input; };
-        if ($@) { $resp = {error => 'decoding error'} };
+        eval { $resp = decode_json $input; 1 }
+            or $resp = {info => "error decoding response", response => $input, cause => $@, return_code => $rc};
     }
     elsif ($rc) {
-        $resp = {error => "qmail-authuser returned code: $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__