adjusted QMailAuthuser to ReadMails Role

3 files changed, 184 insertions, 155 deletions

diff --git a/lib/JWebmail/Controller/Webmail.pm b/lib/JWebmail/Controller/Webmail.pm
index 6e3ff8b..6754ac7 100644
--- a/lib/JWebmail/Controller/Webmail.pm
+++ b/lib/JWebmail/Controller/Webmail.pm
@@ -62,8 +62,7 @@ sub login {
     my $passwd = $v->required('password')->size(4, 50)->like(qr/^.+$/)->param; # no new-lines
 
     if ($v->has_error) {
-        $self->res->code(400);
-        return $self->render(action => 'noaction');
+        return $self->render(action => 'noaction', status => 400);
     }
 
     my $auth = $self->users->Auth(user => $user, password => $passwd);
@@ -77,8 +76,9 @@ sub login {
         $self->redirect_to('displayheaders');
     }
     else {
-        $self->res->code(401);
-        $self->render(action => 'noaction',
+        $self->render(
+            status => 401,
+            action => 'noaction',
             warning => $self->l('login') . ' ' . $self->l('failed') . '!',
         );
     }
@@ -123,8 +123,8 @@ sub displayheaders {
     my $folders = _time { $self->users->folders($auth) } $self, 'user folders';
 
     unless ( $self->stash('folder') ~~ $folders ) {
-        $self->res->code(404);
         $self->render(template => 'error',
+            status => 404,
             error => $self->l('no_folder'),
             links => [map { $self->url_for(folder => $_) } @$folders],
         );
@@ -136,8 +136,7 @@ sub displayheaders {
     my $search = $v->optional('search')->param;
 
     if ($v->has_error) {
-        $self->res->code(400);
-        $self->render(template => 'error', error => "errors in @{ $v->failed }");
+        $self->render(template => 'error', error => "errors in @{ $v->failed }", status => 400);
         return;
     }
 
@@ -195,9 +194,42 @@ sub readmail {
         die $@;
     }
 
-    $self->render(action => 'readmail',
-        msg => $mail,
+    $self->render(msg => $mail);
+}
+
+
+sub raw {
+    my $self = shift;
+
+    my $mid = $self->stash('id');
+
+    my $auth = $self->users->Auth(
+        user      => $self->session(S_USER),
+        password  => $self->session_passwd,
+        challenge => $self->app->secrets->[0],
     );
+
+    my $mail = $self->users->show($auth, $mid);
+
+    my $v = $self->validation;
+    $v->optional('body')->like(qr/\w+/);
+    return if $v->has_error;
+
+    if (my $type = $self->param('body')) {
+        if ($mail->{head}{content_type} =~ '^multipart/') {
+            my ($content) = grep {$_->{head}{content_type} =~ $type} @{ $mail->{body} };
+            $self->render(text => $content->{body});
+        }
+        elsif ($mail->{head}{content_type} =~ $type) {
+            $self->render(text => $mail->{body}) ;
+        }
+        else {
+            $self->reply->not_found;
+        }
+    }
+    else {
+        $self->render(json => $mail);
+    }
 }
 
 
@@ -238,6 +270,7 @@ sub sendmail {
 
         $self->render(action => 'writemail',
             warning => $self->l('error_send'),
+            status => 400,
         );
         return;
     }
@@ -279,44 +312,6 @@ sub move {
 }
 
 
-sub raw {
-    my $self = shift;
-
-    my $mid = $self->stash('id');
-
-    my $auth = $self->users->Auth(
-        user      => $self->session(S_USER),
-        password  => $self->session_passwd,
-        challenge => $self->app->secrets->[0],
-    );
-
-    my $mail = $self->users->show($auth, $mid);
-
-    my $v = $self->validation;
-    $v->optional('body')->like(qr/\w+/);
-    if ($v->has_error) {
-        return;
-    }
-
-    if (my $type = $self->param('body')) {
-        if ($mail->{head}{content_type} =~ '^multipart/') {
-            my ($content) = grep {$_->{head}{content_type} =~ $type} @{ $mail->{body} };
-            $self->render(text => $content->{body});
-        }
-        elsif ($mail->{head}{content_type} =~ $type) {
-            $self->render(text => $mail->{body}) ;
-        }
-        else {
-            $self->res->code(404);
-        }
-    }
-    else {
-        $self->res->headers->content_type('text/plain');
-        $self->render(text => $self->dumper($mail));
-    }
-}
-
-
 1
 
 __END__
@@ -329,15 +324,15 @@ Webmail - All functions comprising the webmail application.
 
 =head1 SYNOPSIS
 
-  my $r = $app->routes;
-  $r->get('/about')->to('Webmail#about');
-  $r->post('/login')->to('Webmail#login');
+    my $r = $app->routes;
+    $r->get('/about')->to('Webmail#about');
+    $r->post('/login')->to('Webmail#login');
 
 =head1 DESCRIPTION
 
 The controller of JWebmail.
 
-=head1 METHODS
+=head1 ROUTES
 
 =head2 noaction
 
@@ -345,9 +340,9 @@ The login page. This should be the root.
 
 =head2 auth
 
-  my $a = $r->under('/')->to('Webmail#auth');
+    my $a = $r->under('/')->to('Webmail#auth');
 
-  An intermediate route that makes sure a user has a valid session.
+    An intermediate route that makes sure a user has a valid session.
 
 =head2 login
 
diff --git a/lib/JWebmail/Model/ReadMails/MockMaildir.pm b/lib/JWebmail/Model/ReadMails/MockMaildir.pm
index 31e9618..d1746ec 100644
--- a/lib/JWebmail/Model/ReadMails/MockMaildir.pm
+++ b/lib/JWebmail/Model/ReadMails/MockMaildir.pm
@@ -1,36 +1,41 @@
 package JWebmail::Model::ReadMails::MockMaildir;
 
-use Mojo::Base -base;
+use Mojo::Base JWebmail::Model::ReadMails::QMailAuthuser;
 
 use Mojo::JSON 'decode_json';
 
+use constant {
+    VALID_USER => 'me@mockmaildir.com',
+    VALID_PW   => '12345',
+};
 
-has user    => sub { $ENV{USER} };
-has maildir => 't/';
+
+has user      => sub { $ENV{USER} };
+has maildir   => 't/';
 has extractor => 'perl';
 
 
 our %EXTRACTORS = (
-    perl => 'perl lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm',
+    perl => 'perl script/qmauth.pl',
     rust => 'extract/target/debug/jwebmail-extract',
 );
 
-use constant {
-    VALID_USER => 'me@mockmaildir.com',
-    VALID_PW   => '12345',
-};
 
-sub communicate {
+sub verify_user {
     my $self = shift;
-    my %args = @_;
+    my $auth = shift;
 
-    if ($args{mode} eq 'auth') {
-        return ("", 0) if $args{user} eq VALID_USER && $args{password} eq VALID_PW;
-        return ("", 1);
-    }
+    return $auth->{user} eq VALID_USER && $auth->{password} eq VALID_PW;
+}
+
+sub build_and_run {
+    my $self = shift;
+    my $auth = shift;
+    my $mode = shift;
+    my $args = shift;
 
     my $mail_user = 'maildir';
-    my $exec = $EXTRACTORS{$self->extractor} . ' ' . join(' ', map { $_ =~ s/(['\\])/\\$1/g; "'$_'" } ($self->maildir, $self->user, $mail_user, $args{mode}, @{$args{args}}));
+    my $exec = $EXTRACTORS{$self->extractor} . ' ' . join(' ', map { $_ =~ s/(['\\])/\\$1/g; "'$_'" } ($self->maildir, $self->user, $mail_user, $mode, @$args));
 
     my $pid = open(my $reader, '-|', $exec)
         or die 'failed to create subprocess';
@@ -49,9 +54,9 @@ sub communicate {
         $resp = {error => "qmail-authuser returned code: $rc"};
     }
 
-    return ($resp, $rc);
+    die "error $resp" if $rc;
+    return $resp;
 }
 
 
 1
-
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__