summaryrefslogtreecommitdiff
path: root/lib/JWebmail/Model/ReadMails
diff options
context:
space:
mode:
Diffstat (limited to 'lib/JWebmail/Model/ReadMails')
-rw-r--r--lib/JWebmail/Model/ReadMails/MockJSON.pm4
-rw-r--r--lib/JWebmail/Model/ReadMails/MockMaildir.pm46
-rw-r--r--lib/JWebmail/Model/ReadMails/QMailAuthuser.pm82
-rw-r--r--lib/JWebmail/Model/ReadMails/Role.pm31
4 files changed, 99 insertions, 64 deletions
diff --git a/lib/JWebmail/Model/ReadMails/MockJSON.pm b/lib/JWebmail/Model/ReadMails/MockJSON.pm
index b90a630..6b3b6d2 100644
--- a/lib/JWebmail/Model/ReadMails/MockJSON.pm
+++ b/lib/JWebmail/Model/ReadMails/MockJSON.pm
@@ -14,8 +14,8 @@ use Role::Tiny::With;
use namespace::clean;
use constant {
- VALID_USER => 'mockjson@example.com',
- VALID_PW => 'vwxyz',
+ VALID_USER => 'mockjson@example.org',
+ VALID_PW => '12345',
};
with 'JWebmail::Model::ReadMails::Role';
diff --git a/lib/JWebmail/Model/ReadMails/MockMaildir.pm b/lib/JWebmail/Model/ReadMails/MockMaildir.pm
index 2df4fa9..9b1bb29 100644
--- a/lib/JWebmail/Model/ReadMails/MockMaildir.pm
+++ b/lib/JWebmail/Model/ReadMails/MockMaildir.pm
@@ -1,38 +1,59 @@
package JWebmail::Model::ReadMails::MockMaildir;
-use Mojo::Base JWebmail::Model::ReadMails::QMailAuthuser;
+use Mojo::Base 'JWebmail::Model::ReadMails::QMailAuthuser';
use Mojo::JSON 'decode_json';
+use Digest::HMAC_MD5 'hmac_md5_hex';
+
+
use constant {
- VALID_USER => 'me@mockmaildir.com',
+ VALID_USER => 'mockmaildir@example.org',
VALID_PW => '12345',
};
-
has user => sub { $ENV{USER} };
has maildir => 't/';
has extractor => 'perl';
-
our %EXTRACTORS = (
- perl => 'perl script/qmauth.pl',
- rust => 'extract/target/debug/jwebmail-extract',
+ perl => 'perl script/qmauth.pl',
+ python => 'python script/qmauth.py',
+ rust => 'extract/target/debug/jwebmail-extract',
);
+sub new {
+ my $cls = shift;
+ my %args = @_ == 1 ? %$_[0] : @_;
+
+ my $self = bless {%args}, ref $cls || $cls;
+ $self->user;
+ $self->maildir;
+
+ $self->next::method(prog => $EXTRACTORS{$self->extractor});
+ return $self;
+}
+
+
sub verify_user {
my $self = shift;
my $auth = shift;
- return $auth->{user} eq VALID_USER && $auth->{password} eq VALID_PW;
+ my $passwd = $auth->{password}->show_password;
+
+ if ($auth->{challenge}) {
+ return $auth->{user} eq VALID_USER &&
+ $passwd eq hmac_md5_hex($auth->{challenge}, VALID_PW);
+ }
+ else {
+ return $auth->{user} eq VALID_USER && $passwd eq VALID_PW;
+ }
}
sub build_and_run {
my $self = shift;
- my $auth = shift;
- my $mode = shift;
- my $args = shift;
+ my ($auth, $mode, $args) = @_;
my $mail_user = 'maildir';
my $exec = $EXTRACTORS{$self->extractor} . ' ' . join(' ', map { my $x = s/(['\\])/\\$1/gr; "'$x'" } ($self->maildir, $self->user, $mail_user, $mode, @$args));
@@ -51,10 +72,11 @@ sub build_and_run {
if (my $err = $@) { $resp = {error => "decoding error '$err'"}; $rc ||= 1; };
}
elsif ($rc) {
- $resp = {error => "qmail-authuser returned code: $rc"};
+ $resp = {error => "qmauth returned code: $rc"};
}
- die "error $resp" if $rc;
+ local $" = ', ';
+ die "error @{[%$resp]}" if $rc;
return $resp;
}
diff --git a/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
index 39d8ab6..956c137 100644
--- a/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
+++ b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm
@@ -8,8 +8,8 @@ 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 Scalar::Util 'blessed';
use namespace::clean;
with 'JWebmail::Model::ReadMails::Role';
@@ -51,7 +51,10 @@ package JWebmail::Model::ReadMails::QMailAuthuser::Error {
my $cls = shift;
my $msg = shift;
- die $cls->new($msg, @_)->_trace;
+ my $self = $cls->new($msg, @_);
+ $self->_trace;
+
+ die $self;
}
# taken from Mojo::Exception
@@ -70,12 +73,12 @@ package JWebmail::Model::ReadMails::QMailAuthuser::Error {
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'},
+ user => {required => 1},
+ maildir => {required => 1},
+ prog => {required => 1},
+ prefix => {default => ''},
+ qmail_dir => {default => '/var/qmail/'},
+ logfile => {default => '/dev/null'},
};
sub new {
@@ -86,8 +89,12 @@ sub new {
$self = {%$cls, %$self};
$cls = $pkg;
}
- $self = check($QMailAuthuserCheck, $self, 1) || die;
- return bless $self, $cls;
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+ local $Params::Check::ONLY_ALLOW_DEFINED = 1;
+ local $Params::Check::WARNINGS_FATAL = 1;
+ my $s = check($QMailAuthuserCheck, $self)
+ or die __PACKAGE__ . " creation failed!";
+ return bless $s, $cls;
}
@@ -95,8 +102,8 @@ sub verify_user {
my $self = shift;
my $auth = shift;
- eval { $self->build_and_run($auth, 'auth'); 1 }
- or do {
+ return eval { $self->build_and_run($auth, 'auth'); 1 }
+ || do {
my $e = $@;
my $rc = eval { $e->data->{return_code} };
if ($rc == 1) {
@@ -115,22 +122,21 @@ sub read_headers_for {
my %h = @_;
my ($folder, $start, $end, $sort) = @h{qw(folder start end sort)};
- return $self->build_and_run($auth, 'list', [$start, $end, $sort, $folder]);
+ return $self->build_and_run($auth, 'list', [$folder, $start, $end, $sort]);
}
sub count {
my $self = shift;
my ($auth, $folder) = @_;
- my $resp = $self->build_and_run($auth, 'count', [$folder]);
- return ($resp->{size}, $resp->{count}, $resp->{new});
+ return $self->build_and_run($auth, 'count', [$folder]);
}
sub show {
my $self = shift;
- my ($auth, $mid) = @_;
+ my ($auth, $folder, $mid) = @_;
- return $self->build_and_run($auth, 'read-mail', [$mid]);
+ return $self->build_and_run($auth, 'read', [$folder, $mid]);
}
sub search {
@@ -144,23 +150,23 @@ sub folders {
my $self = shift;
my ($auth) = @_;
- return $self->build_and_run($auth, 'folders');
+ my $res = $self->build_and_run($auth, 'folders');
+ unshift @$res, '' if ref $res eq 'ARRAY';
+ return $res;
}
sub move {
my $self = shift;
- my ($auth, $mid, $folder) = @_;
+ my ($auth, $mid, $from_f, $to_f) = @_;
- my $_resp = $self->build_and_run($auth, 'move', [$mid, $folder]);
+ my $_resp = $self->build_and_run($auth, 'move', [$mid, $from_f, $to_f]);
return 1;
}
sub build_arg {
my $self = shift;
- my $user_mail_addr = shift;
- my $mode = shift;
- my $args = shift || [];
+ my ($user_mail_addr, $mode, $args) = @_;
return $self->{qmail_dir} . "/bin/qmail-authuser true 3<&0"
if $mode eq 'auth';
@@ -169,15 +175,14 @@ sub build_arg {
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))
+ . 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 ($auth, $exec) = @_;
my $pid = open2(my $reader, my $writer, $exec)
or die 'failed to create subprocess';
@@ -190,18 +195,28 @@ sub execute {
binmode $reader, ':encoding(UTF-8)';
my $input = <$reader>;
- close $reader # waits for the child to finish
+ 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; 1 }
- or $resp = {info => "error decoding response", response => $input, cause => $@, return_code => $rc};
+ 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};
+ $resp = {
+ info => "got unsuccessful return code by qmail-authuser",
+ return_code => $rc,
+ response => $input,
+ };
}
return ($resp, $rc);
@@ -209,15 +224,14 @@ sub execute {
sub build_and_run {
my $self = shift;
- my $auth = shift;
- my $mode = shift;
- my $args = shift;
+ my ($auth, $mode, $args) = @_;
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);
+ JWebmail::Model::ReadMails::QMailAuthuser::Error->throw(
+ "qmail-authuser connection error", $resp);
}
return $resp;
}
@@ -291,5 +305,3 @@ Challenge when using cram
=head1 SEE ALSO
L<JWebmail::Model::ReadMails>, L<JWebmail::Model::Driver::QMailAuthuser::Extract>
-
-=cut
diff --git a/lib/JWebmail/Model/ReadMails/Role.pm b/lib/JWebmail/Model/ReadMails/Role.pm
index 1f4390b..d6fa1e5 100644
--- a/lib/JWebmail/Model/ReadMails/Role.pm
+++ b/lib/JWebmail/Model/ReadMails/Role.pm
@@ -1,6 +1,6 @@
package JWebmail::Model::ReadMails::Role;
-use Params::Check 'check';
+use Params::Check qw(check last_error);
use Mojo::Base -role; # load after imports
@@ -18,13 +18,15 @@ package JWebmail::Model::ReadMails::Role::Shadow {
sub Auth {
shift;
state $AuthCheck = {
- user => {defined => 1, required => 1},
- password => {defined => 1, required => 1},
+ user => {required => 1, defined => 1},
+ password => {required => 1, defined => 1},
challenge => {},
};
my $self = @_ == 1 ? $_[0] : {@_};
- my $res = check($AuthCheck, $self, 0) || die Params::Check::last_error;
+ local $Params::Check::WARNINGS_FATAL = 1;
+ my $res = check($AuthCheck, $self, 0)
+ or die 'Auth creation failed! ' . last_error;
$res->{password} = JWebmail::Model::ReadMails::Role::Shadow->new($res->{password});
return $res;
}
@@ -36,14 +38,14 @@ my @methods = (
# ^ throws exception
# ^type throws exception of type
# Read operations
- 'verify_user', # auth:Auth -> :truthy
- 'read_headers_for', # auth:Auth, *folder='', *start=0, *end=24, *sort='date' -> ^ :hashref
'count', # auth:Auth, folder -> ^ size:int count:int new:int
- 'show', # auth:Auth, mid -> ^ :hashref
- 'search', # auth:Auth, pattern, folder -> ^ :hashref
'folders', # auth:Auth -> ^ :arrayref
+ 'verify_user', # auth:Auth -> :truthy
# Write operations
'move', # auth:Auth, mid, folder -> ^ 1
+ 'read_headers_for', # auth:Auth, *folder='', *start=0, *end=24, *sort='date' -> ^ :hashref
+ 'search', # auth:Auth, pattern, folder -> ^ :hashref
+ 'show', # auth:Auth, mid -> ^ :hashref
);
requires(@methods);
@@ -66,13 +68,14 @@ around read_headers_for => sub {
my $args = {@_};
state $ArgsCheck = {
- start => {default => 0},
- end => {default => 24},
- sort => {default => 'date'},
+ start => {required => 1},
+ end => {required => 1},
+ sort => {default => ''},
folder => {default => ''},
};
- $orig->($self, $auth, %{ check($ArgsCheck, $args, 1) })
+ local $Params::Check::ONLY_ALLOW_DEFINED = 1;
+ $orig->($self, $auth, %{ check($ArgsCheck, $args, 0) or die last_error })
};
@@ -107,7 +110,7 @@ Provides bundeled information on a subset of mails of a mailbox.
Can be sorted and of varying size.
Arguments:
- start..end inclusive 0 based range
+ start..end half open 0 based range
=head2 count
@@ -150,5 +153,3 @@ Optinal challange for when you use cram authentication.
=head1 SEE ALSO
L<JWebmail::Model::ReadMails::QMailAuthuser>, L<JWebmail::Model::ReadMails::Mock>, L<JWebmail>
-
-=cut
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 01:13:22 +0000