diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.PL | 30 | ||||
| -rw-r--r-- | jwebmail.development.conf | 3 | ||||
| -rw-r--r-- | lib/JWebmail.pm | 38 | ||||
| -rw-r--r-- | lib/JWebmail/Controller/Webmail.pm | 47 | ||||
| -rw-r--r-- | lib/JWebmail/Model/Driver/MockJSON.pm | 104 | ||||
| -rw-r--r-- | lib/JWebmail/Model/Driver/QMailAuthuser.pm | 138 | ||||
| -rw-r--r-- | lib/JWebmail/Model/ReadMails.pm | 230 | ||||
| -rw-r--r-- | lib/JWebmail/Model/ReadMails/MockJSON.pm | 119 | ||||
| -rw-r--r-- | lib/JWebmail/Model/ReadMails/MockMaildir.pm (renamed from lib/JWebmail/Model/Driver/MockMaildir.pm) | 2 | ||||
| -rw-r--r-- | lib/JWebmail/Model/ReadMails/QMailAuthuser.pm | 267 | ||||
| -rw-r--r-- | lib/JWebmail/Model/ReadMails/Role.pm | 129 | ||||
| -rw-r--r-- | lib/JWebmail/Model/ReadMails/schema.json (renamed from lib/JWebmail/Model/Driver/QMailAuthuser/schema.json) | 0 | ||||
| -rw-r--r-- | lib/JWebmail/Plugin/INIConfig.pm | 6 | ||||
| -rwxr-xr-x | script/qmauth.pl (renamed from lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm) | 3 | ||||
| -rw-r--r-- | t/Webmail.t | 4 |
16 files changed, 580 insertions, 541 deletions
@@ -7,3 +7,4 @@ Makefile .vscode/* t/private extract/target +*.bak diff --git a/Makefile.PL b/Makefile.PL index b51c6b4..ac6013a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,20 +1,18 @@ -use strict; -use warnings; - use ExtUtils::MakeMaker; WriteMakefile( - AUTHOR => '"Jannis M. Hoffmann" <jannis@fehcom.de>', - MIN_PERL_VERSION => 'v5.22', - NAME => 'JWebmail', - VERSION_FROM => 'lib/JWebmail.pm', - LICENSE => 'gpl_3', - PREREQ_PM => { - 'Mojolicious' => '8.64', - 'Config::Tiny' => 'v2.24', - 'Crypt::URandom' => 0, - 'Email::MIME' => 0, - 'Mail::Box::Manager' => 'v3.9', - }, - test => {TESTS => 't/*.t'} + AUTHOR => '"Jannis M. Hoffmann" <jannis@fehcom.de>', + MIN_PERL_VERSION => 'v5.22', + NAME => 'JWebmail', + VERSION_FROM => 'lib/JWebmail.pm', + LICENSE => 'gpl_3', + PREREQ_PM => { + 'Mojolicious' => '8.64', + 'Config::Tiny' => 'v2.24', + 'Crypt::URandom' => 0, + 'Email::MIME' => 0, + 'Mail::Box::Manager' => 'v3.9', + 'Role::Tiny' => 'v2.0.1', + }, + test => {TESTS => 't/*.t'} ) diff --git a/jwebmail.development.conf b/jwebmail.development.conf index bab91bf..4daeb16 100644 --- a/jwebmail.development.conf +++ b/jwebmail.development.conf @@ -18,8 +18,7 @@ directory = lang #sendmail = /usr/sbin/sendmail [development] -#use_read_mock = maildir -use_read_mock = json +read_mock = JWebmail::Model::ReadMails::MockJSON ; JWebmail::Model::ReadMails::MockMaildir block_writes = 1 [session] diff --git a/lib/JWebmail.pm b/lib/JWebmail.pm index 2c03d1b..82c94c1 100644 --- a/lib/JWebmail.pm +++ b/lib/JWebmail.pm @@ -1,15 +1,12 @@ -package JWebmail v1.1.0; +package JWebmail v1.2.0; use Mojo::Base 'Mojolicious'; use JWebmail::Controller::Webmail; -use JWebmail::Model::ReadMails; -use JWebmail::Model::Driver::QMailAuthuser; +use JWebmail::Model::ReadMails::Role; +use JWebmail::Model::ReadMails::QMailAuthuser; use JWebmail::Model::WriteMails; -use JWebmail::Model::Driver::MockJSON; -use JWebmail::Model::Driver::MockMaildir; - sub startup { my $self = shift; @@ -31,22 +28,23 @@ sub startup { delete $self->config->{secret}; # initialize models - no warnings "experimental::smartmatch"; - my $driver = do { - given ($self->config->{development}{use_read_mock}) { - when (/^json/) { JWebmail::Model::Driver::MockJSON->new() } - when (/^maildir/) { JWebmail::Model::Driver::MockMaildir->new(extractor => 'rust') } - default { - JWebmail::Model::Driver::QMailAuthuser->new( - logfile => $self->home->child('log', 'extract.log'), - %{ $self->config->{model}{read}{driver} // {} }) - } + my $read_mails = do { + if ($mode eq 'development') { + my $cls = $self->config->{development}{read_mock}; + eval "require $cls" || die "Issue for module $cls with: $@"; + $cls->new; + } + else { + JWebmail::Model::ReadMails::QMailAuthuser->new( + logfile => $self->home->child('log', 'extract.log'), + ); } }; - my $read_mails = JWebmail::Model::ReadMails->new(driver => $driver); + die "given class @{[ ref $read_mails ]} does not ReadMails" + unless $read_mails->DOES('JWebmail::Model::ReadMails::Role'); $self->helper(users => sub { $read_mails }); $self->helper(send_mail => sub { my ($c, $mail) = @_; JWebmail::Model::WriteMails::sendmail($mail) }); - $JWebmail::Model::WriteMails::Block_Writes = 1 if $self->config->{development}{block_writes}; + $JWebmail::Model::WriteMails::Block_Writes = 1 if $mode eq 'development'; $self->defaults(version => __PACKAGE__->VERSION); @@ -57,7 +55,7 @@ sub startup { sub route { my $self = shift; - my $r = shift // $self->routes; + my $r = shift || $self->routes; $r->get('/' => 'noaction')->to('Webmail#noaction'); $r->get('/about')->to('Webmail#about'); @@ -86,7 +84,7 @@ JWebmail - Provides a web based e-mail client meant to be used with s/qmail. =head1 SYNOPSIS - hypnotoad script/jwebmail + hypnotoad script/jwebmail And use a server in reverse proxy configuration. diff --git a/lib/JWebmail/Controller/Webmail.pm b/lib/JWebmail/Controller/Webmail.pm index cd7b5c7..3566c83 100644 --- a/lib/JWebmail/Controller/Webmail.pm +++ b/lib/JWebmail/Controller/Webmail.pm @@ -47,7 +47,7 @@ sub _time :prototype(&$$) { my @res = $code->(); my $elapsed = $self->timing->elapsed($name); - $self->app->log->debug("$name took $elapsed seconds"); + $self->app->log->debug(sprintf("%s took %fs", $name, $elapsed)); return wantarray ? @res : $res[-1]; } @@ -60,13 +60,14 @@ sub login { my $user = $v->required('userid')->size(4, 50)->param; my $passwd = $v->required('password')->size(4, 50)->like(qr/^.+$/)->param; # no new-lines + my $auth = $self->users->Auth(user => $user, password => $passwd); if ($v->has_error) { $self->res->code(400); return $self->render(action => 'noaction'); } - my $valid = _time { $self->users->verify_user($user, $passwd) } $self, 'verify user'; + my $valid = _time { $self->users->verify_user($auth) } $self, 'verify user'; if ($valid) { $self->session(S_USER() => $user); @@ -113,14 +114,13 @@ sub displayheaders { no warnings 'experimental::smartmatch'; my $self = shift; - my $auth = AuthReadMails->new( + my $auth = $self->users->Auth( user => $self->session(S_USER), password => $self->session_passwd, challenge => $self->app->secrets->[0], ); my $folders = _time { $self->users->folders($auth) } $self, 'user folders'; - push @$folders, ''; unless ( $self->stash('folder') ~~ $folders ) { $self->res->code(404); @@ -146,23 +146,24 @@ sub displayheaders { my ($start, $end) = $self->paginate($cnt); $self->timing->begin('user_headers'); - my $headers; - if ($search) { - $headers = $self->users->search( - $auth, $search, $self->stash('folder'), - ); - } - else { - $headers = $self->users->read_headers_for( - auth => $auth, - folder => $self->stash('folder'), - start => $start, - end => $end, - sort => $sort, - ); - } + my $headers = do { + if ($search) { + $self->users->search( + $auth, $search, $self->stash('folder'), + ) + } + else { + $self->users->read_headers_for( + $auth, + folder => $self->stash('folder'), + start => $start, + end => $end, + sort => $sort, + ) + } + }; my $elapsed = $self->timing->elapsed('user_headers'); - $self->app->log->debug("Reading user headers took $elapsed seconds"); + $self->app->log->debug(sprintf("Reading user headers took %fs", $elapsed)); $self->stash( msgs => $headers, @@ -178,7 +179,7 @@ sub readmail { my $mid = $self->stash('id'); - my $auth = AuthReadMails->new( + my $auth = $self->users->Auth( user => $self->session(S_USER), password => $self->session_passwd, challenge => $self->app->secrets->[0], @@ -257,7 +258,7 @@ sub move { return; } - my $auth = AuthReadMails->new( + my $auth = $self->users->Auth( user => $self->session(S_USER), password => $self->session_passwd, challenge => $self->app->secrets->[0], @@ -283,7 +284,7 @@ sub raw { my $mid = $self->stash('id'); - my $auth = AuthReadMails->new( + my $auth = $self->users->Auth( user => $self->session(S_USER), password => $self->session_passwd, challenge => $self->app->secrets->[0], diff --git a/lib/JWebmail/Model/Driver/MockJSON.pm b/lib/JWebmail/Model/Driver/MockJSON.pm deleted file mode 100644 index 258246d..0000000 --- a/lib/JWebmail/Model/Driver/MockJSON.pm +++ /dev/null @@ -1,104 +0,0 @@ -package JWebmail::Model::Driver::MockJSON; - -use Mojo::Base -base; - -use List::Util 'sum'; - -use Mojo::JSON qw(decode_json); - - -use constant { - VALID_USER => 'mockjson@example.com', - VALID_PW => 'vwxyz', -}; - -use constant { - LIST_START => 0, - LIST_END => 1, - LIST_SORT => 2, - LIST_FOLDER => 3, -}; - -sub _read_json_file { - my ($file_name) = @_; - - use constant PREFIX => 't/private/'; - - open(my $body_file, '<', PREFIX . $file_name); - local $/; - my $body = <$body_file>; - close $body_file; - - return decode_json($body); -} - - -sub list_reply { - state $init = _read_json_file('msgs.json'); -} -sub read_reply { - state $init = { - 'SC-ORD-MAIL54526c63b751646618a793be3f8329cca@sc-ord-mail5' => _read_json_file('msg2.json'), - 'example' => _read_json_file('msg.json'), - }; -} - - -sub communicate { - no warnings 'experimental::smartmatch'; - - my $self = shift; - - my %args = @_; - - given ($args{mode}) { - when ('auth') { - return (undef, 0) if $args{user} eq VALID_USER && $args{password} eq VALID_PW; - return (undef, 2); - } - when ('list') { - return ([@{ $self->list_reply }[$args{args}->[LIST_START]..$args{args}->[LIST_END]]], 0) if !$args{args}->[LIST_SORT]; - return ([], 0) if $args{args}->[LIST_FOLDER] eq 'test'; - my $s = sub { - my $sort_by = $args{args}->[LIST_SORT]; - my $rev = $sort_by !~ m/^![[:lower:]]+/ ? 1 : -1; - $sort_by =~ s/^!//; - return (($a->{$sort_by}||$a->{head}{$sort_by}) cmp ($b->{$sort_by}||$b->{head}{$sort_by})) * $rev; - }; - return ([sort { &$s } @{ $self->list_reply }[$args{args}->[LIST_START]..$args{args}->[LIST_END]]], 0); - } - when ('count') { - return ({ - count => scalar(@{ $self->list_reply }), - size => sum(map {$_->{size}} @{ $self->list_reply }), - new => 0, - }, 0); - } - when ('read-mail') { - my $mid = $args{args}->[0]; - my $mail = $self->read_reply->{$mid}; - return ($mail, 0) if $mail; - return ({error => 'unkown mail-id'}, 3); - } - when ('folders') { - return ([qw(cur test devel debug)], 0); - } - when ('move') { - local $, = ' '; - say "@{ $args{args} }"; - return (undef, 0); - } - default { return ({error => 'unkown mode'}, 3); } - } -} - - -1 - -__END__ - -=head1 NAME - -Mock - Simple file based mock for the L<JWebmail::Model::ReadMails> module. - -=cut diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser.pm b/lib/JWebmail/Model/Driver/QMailAuthuser.pm deleted file mode 100644 index a310024..0000000 --- a/lib/JWebmail/Model/Driver/QMailAuthuser.pm +++ /dev/null @@ -1,138 +0,0 @@ -package JWebmail::Model::Driver::QMailAuthuser; - -use Mojo::Base -base; - -use IPC::Open2; -use File::Basename 'fileparse'; -use JSON::PP 'decode_json'; - - -has 'user'; -has 'maildir'; -has 'prefix' => ''; -has qmail_dir => '/var/qmail/'; -has prog => [fileparse(__FILE__)]->[1] . '/QMailAuthuser/Extract.pm'; -has logfile => '/dev/null'; - - -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 - - my $m = JWebmail::Model::ReadMails->new(driver => JWebmail::Model::Driver::QMailAuthuser->new(...)); - -=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 diff --git a/lib/JWebmail/Model/ReadMails.pm b/lib/JWebmail/Model/ReadMails.pm deleted file mode 100644 index e541de1..0000000 --- a/lib/JWebmail/Model/ReadMails.pm +++ /dev/null @@ -1,230 +0,0 @@ -package JWebmail::Model::ReadMails; - -use Mojo::Base -base; - -use Class::Struct AuthReadMails => { - user => '$', - password => '$', - challenge => '$', -}; - - -has 'driver'; - - -sub verify_user { - - my $self = shift; - - my ($user, $password) = @_; - - return !scalar $self->driver->communicate( - user => $user, - password => $password, - mode => 'auth', - ) -} - - -sub read_headers_for { - - my $self = shift; - - my %h = @_; - my ($auth, $folder, $start, $end, $sort) = @h{qw(auth folder start end sort)}; - - my ($resp, $rc) = $self->driver->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->driver->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->driver->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->driver->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->driver->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->driver->communicate( - user => $auth->user, - password => $auth->password, - challenge => $auth->challenge, - mode => 'move', - args => [$mid, $folder], - ); - die "connection error: $resp->{error}" if $rc; - return 1; -} - - -1 - -__END__ - -=encoding utf-8 - -=head1 NAME - -ReadMails - Read received mails - -=head1 SYNOPSIS - - my $m = JWebmail::Model::ReadMails->new(driver => ...); - $m->search($auth, qr/Hot singles in your area/, ''); - -=head1 DESCRIPTION - -This module is a facade for the actions of its driver. -All actions are delegated to it. - -The first parameter is authentication info as AuthReadMails -whith the rest varying. - -The communication is stateless. - -=head1 ATTRIBUTES - -=head2 driver - -The driver does the actual work of reading the mailbox. - -=head1 METHODS - -=head2 new - -Instantiate a new object. The 'driver' option is required. - -=head2 verify_user - -Checks user name and password. - -=head2 read_headers_for - -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 - -=head2 count - -Returns size of the mail box folder in bytes the number of mails. - -=head2 show - -Returns a sepecific mail as a perl hash. - -=head2 search - -Searches for a message with the given pattern. - -=head2 folders - -List all mailbox sub folders. - -=head2 move - -Move mails between folders. - -=head1 CLASSES - -=head2 AuthReadMails - -A struct that bundles auth data. - -=head3 Attributes - -=head4 user - -The user name. - -=head4 password - -The users password in plaintext or as hmac if cram is used. - -=head4 challenge - -Optinal challange for when you use cram authentication. - -=head3 Methods - -=head4 new - -=head1 SEE ALSO - -L<JWebmail::Model::Driver::QMailAuthuser>, L<JWebmail::Model::Driver::Mock>, L<JWebmail> - -=cut diff --git a/lib/JWebmail/Model/ReadMails/MockJSON.pm b/lib/JWebmail/Model/ReadMails/MockJSON.pm new file mode 100644 index 0000000..bb105d1 --- /dev/null +++ b/lib/JWebmail/Model/ReadMails/MockJSON.pm @@ -0,0 +1,119 @@ +package JWebmail::Model::ReadMails::MockJSON; + +use v5.24; +use warnings; +use utf8; + +use List::Util 'sum'; + +use Role::Tiny::With; + +use Mojo::JSON qw(decode_json); + +use constant { + VALID_USER => 'mockjson@example.com', + VALID_PW => 'vwxyz', +}; + +use namespace::clean; + +with 'JWebmail::Model::ReadMails::Role'; + + +sub new { bless {} } + +sub _read_json_file { + my ($file_name) = @_; + + use constant PREFIX => 't/private/'; + + open(my $body_file, '<', PREFIX . $file_name); + local $/; + my $body = <$body_file>; + close $body_file; + + return decode_json($body); +} + +sub list_reply { + state $init = _read_json_file('msgs.json'); +} + +sub read_reply { + state $init = { + 'SC-ORD-MAIL54526c63b751646618a793be3f8329cca@sc-ord-mail5' => _read_json_file('msg2.json'), + 'example' => _read_json_file('msg.json'), + }; +} + + +sub verify_user { + my $self = shift; + my $auth = shift; + + return $auth->{user} eq VALID_USER && $auth->{password} eq VALID_PW; +} + +sub read_headers_for { + my $self = shift; + my $auth = shift; + my %args = @_; + + my ($start, $end, $sort, $folder) = @args{qw(start end sort folder)}; + + unless ($sort) { + return [@{ $self->list_reply }[$start..$end]]; + } + if ($folder eq 'test') { + return []; + } + my $s = sub { + my $sort_by = $sort; + my $rev = $sort_by !~ m/^![[:lower:]]+/ ? 1 : -1; + $sort_by =~ s/^!//; + return (($a->{$sort_by}||$a->{head}{$sort_by}) cmp ($b->{$sort_by}||$b->{head}{$sort_by})) * $rev; + }; + return [sort { &$s } @{ $self->list_reply }[$start..$end]]; +} + +sub count { + my $self = shift; + my $auth = shift; + my $_folder = shift; + + return ( + sum(map {$_->{size}} @{ $self->list_reply }), # size + scalar(@{ $self->list_reply }), # count + 0, # new + ); +} + +sub show { + my $self = shift; + my $auth = shift; + my $mid = shift; + + my $mail = $self->read_reply->{$mid}; + if ($mail) { + return $mail; + } + else { + die 'unkown mail-id'; + } +} + +sub folders { ['', qw(cur test devel debug)] } + +sub search { ... } +sub move { ... } + + +1 + +__END__ + +=head1 NAME + +Mock - Simple file based mock for the L<JWebmail::Model::ReadMails> module. + +=cut diff --git a/lib/JWebmail/Model/Driver/MockMaildir.pm b/lib/JWebmail/Model/ReadMails/MockMaildir.pm index e8956ed..31e9618 100644 --- a/lib/JWebmail/Model/Driver/MockMaildir.pm +++ b/lib/JWebmail/Model/ReadMails/MockMaildir.pm @@ -1,4 +1,4 @@ -package JWebmail::Model::Driver::MockMaildir; +package JWebmail::Model::ReadMails::MockMaildir; use Mojo::Base -base; 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 diff --git a/lib/JWebmail/Model/ReadMails/Role.pm b/lib/JWebmail/Model/ReadMails/Role.pm new file mode 100644 index 0000000..3c6d7ee --- /dev/null +++ b/lib/JWebmail/Model/ReadMails/Role.pm @@ -0,0 +1,129 @@ +package JWebmail::Model::ReadMails::Role; + +use Params::Check 'check'; + +use Mojo::Base -role; # load after imports + + +sub Auth { + shift; + state $AuthCheck = { + user => {required => 1, defined => 1}, + password => {required => 1, defined => 1}, + challenge => {defined => 1}, + }; + my $self = @_ == 1 ? {$_[0]} : {@_}; + + return check($AuthCheck, $self, 1) || die; +} + +requires( + # name:type parmeter of type + # *key key => value + # key=value default argument of value + # ^ 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 + # Write operations + 'move', # auth:Auth, mid, folder -> ^ 1 +); + +around read_headers_for => sub { + my $orig = shift; + my $self = shift; + my $auth = shift; + my $args = {@_}; + + state $ArgsCheck = { + start => {default => 0}, + end => {default => 24}, + sort => {default => 'date'}, + folder => {default => ''}, + }; + + $orig->($self, $auth, %{ check($ArgsCheck, $args, 1) }) +}; + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +ReadMails::Role - Interface to a repository of mails + +=head1 SYNOPSIS + + my $m = Some::Implementation->with_role('JWebmail::Model::ReadMails::Role'); + $m->search($auth, qr/Hot singles in your area/, ''); + +=head1 DESCRIPTION + +The communication is assumed to be stateless. + +=head1 INTERFACE + +=head2 verify_user + +Checks user name and password. + +=head2 read_headers_for + +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 + +=head2 count + +Returns size of the mail box folder in bytes the number of mails. + +=head2 show + +Returns a sepecific mail as a perl hash. + +=head2 search + +Searches for a message with the given pattern. + +=head2 folders + +List all mailbox sub folders. + +=head2 move + +Move mails between folders. + +=head2 Auth + +A sub that returns a hashref of bundled authentication data. + +=head3 Attributes + +=head4 user + +The user name. + +=head4 password + +The users password in plaintext or as hmac if cram is used. + +=head4 challenge + +Optinal challange for when you use cram authentication. + +=head1 SEE ALSO + +L<JWebmail::Model::ReadMails::QMailAuthuser>, L<JWebmail::Model::ReadMails::Mock>, L<JWebmail> + +=cut diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser/schema.json b/lib/JWebmail/Model/ReadMails/schema.json index b63a5eb..b63a5eb 100644 --- a/lib/JWebmail/Model/Driver/QMailAuthuser/schema.json +++ b/lib/JWebmail/Model/ReadMails/schema.json diff --git a/lib/JWebmail/Plugin/INIConfig.pm b/lib/JWebmail/Plugin/INIConfig.pm index fe0fb1a..be9841e 100644 --- a/lib/JWebmail/Plugin/INIConfig.pm +++ b/lib/JWebmail/Plugin/INIConfig.pm @@ -7,7 +7,7 @@ use Config::Tiny; sub parse { - my ($self, $content, $file, $conf, $app) = @_; + my ($self, $content, $file, $conf, $_app) = @_; my $ct = Config::Tiny->new; my $config = $ct->read_string($content, 'utf8'); @@ -102,7 +102,7 @@ INIConfig - Reads in ini config files. INI configuration is simple with limited nesting and propper comments. For more precise specification on the syntax see the Config::Tiny documentation -on metacpan. +on cpan. =head1 OPTIONS @@ -133,4 +133,4 @@ overrides the parse method of Mojolicious::Plugin::Config Config::Tiny -=cut
\ No newline at end of file +=cut diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm b/script/qmauth.pl index a59e265..5bc7bb5 100755 --- a/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm +++ b/script/qmauth.pl @@ -1,8 +1,7 @@ #!/usr/bin/env perl -package JWebmail::Model::Driver::QMailAuthuser::Extract; +package JWebmail::QMAuth; use v5.18; -use strict; use warnings; use utf8; diff --git a/t/Webmail.t b/t/Webmail.t index 06efd49..4cef937 100644 --- a/t/Webmail.t +++ b/t/Webmail.t @@ -5,7 +5,7 @@ use utf8; use Test::More; use Test::Mojo; -use JWebmail::Model::Driver::MockJSON; +use JWebmail::Model::ReadMails::MockJSON; use constant DEFAULT_LANGUAGE => 'en'; @@ -14,7 +14,7 @@ my $pw = JWebmail::Model::Driver::MockJSON::VALID_PW; my $t = Test::Mojo->new('JWebmail', { - development => { use_read_mock => 'json', block_writes => 1 }, + development => { read_mock => 'JWebmail::Model::ReadMails::MockJSON', block_writes => 1 }, i18n => { default_language => DEFAULT_LANGUAGE }, }); |