From a97f1a5eb6649e93bfd6584ed590e37c1290755f Mon Sep 17 00:00:00 2001 From: "Jannis M. Hoffmann" Date: Mon, 25 Apr 2022 16:52:57 +0200 Subject: Refactored ReadMails into a role --- lib/JWebmail/Model/Driver/MockJSON.pm | 104 -------- lib/JWebmail/Model/Driver/MockMaildir.pm | 57 ---- lib/JWebmail/Model/Driver/QMailAuthuser.pm | 138 ---------- lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm | 296 --------------------- .../Model/Driver/QMailAuthuser/schema.json | 83 ------ lib/JWebmail/Model/ReadMails.pm | 230 ---------------- lib/JWebmail/Model/ReadMails/MockJSON.pm | 119 +++++++++ lib/JWebmail/Model/ReadMails/MockMaildir.pm | 57 ++++ lib/JWebmail/Model/ReadMails/QMailAuthuser.pm | 267 +++++++++++++++++++ lib/JWebmail/Model/ReadMails/Role.pm | 129 +++++++++ lib/JWebmail/Model/ReadMails/schema.json | 83 ++++++ 11 files changed, 655 insertions(+), 908 deletions(-) delete mode 100644 lib/JWebmail/Model/Driver/MockJSON.pm delete mode 100644 lib/JWebmail/Model/Driver/MockMaildir.pm delete mode 100644 lib/JWebmail/Model/Driver/QMailAuthuser.pm delete mode 100755 lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm delete mode 100644 lib/JWebmail/Model/Driver/QMailAuthuser/schema.json delete mode 100644 lib/JWebmail/Model/ReadMails.pm create mode 100644 lib/JWebmail/Model/ReadMails/MockJSON.pm create mode 100644 lib/JWebmail/Model/ReadMails/MockMaildir.pm create mode 100644 lib/JWebmail/Model/ReadMails/QMailAuthuser.pm create mode 100644 lib/JWebmail/Model/ReadMails/Role.pm create mode 100644 lib/JWebmail/Model/ReadMails/schema.json (limited to 'lib/JWebmail/Model') 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 module. - -=cut diff --git a/lib/JWebmail/Model/Driver/MockMaildir.pm b/lib/JWebmail/Model/Driver/MockMaildir.pm deleted file mode 100644 index e8956ed..0000000 --- a/lib/JWebmail/Model/Driver/MockMaildir.pm +++ /dev/null @@ -1,57 +0,0 @@ -package JWebmail::Model::Driver::MockMaildir; - -use Mojo::Base -base; - -use Mojo::JSON 'decode_json'; - - -has user => sub { $ENV{USER} }; -has maildir => 't/'; -has extractor => 'perl'; - - -our %EXTRACTORS = ( - perl => 'perl lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm', - rust => 'extract/target/debug/jwebmail-extract', -); - -use constant { - VALID_USER => 'me@mockmaildir.com', - VALID_PW => '12345', -}; - -sub communicate { - my $self = shift; - my %args = @_; - - if ($args{mode} eq 'auth') { - return ("", 0) if $args{user} eq VALID_USER && $args{password} eq VALID_PW; - return ("", 1); - } - - 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 $pid = open(my $reader, '-|', $exec) - or die 'failed to create subprocess'; - - my $input = <$reader>; - - waitpid($pid, 0); - my $rc = $? >> 8; - - my $resp; - if ($rc == 3 || $rc == 0) { - eval { $resp = decode_json $input; }; - if (my $err = $@) { $resp = {error => "decoding error '$err'"}; $rc ||= 1; }; - } - elsif ($rc) { - $resp = {error => "qmail-authuser returned code: $rc"}; - } - - return ($resp, $rc); -} - - -1 - 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 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. - -=head2 prog - -The path to the extractor programm. -Default is the location of L 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, L - -=cut diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm b/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm deleted file mode 100755 index a59e265..0000000 --- a/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm +++ /dev/null @@ -1,296 +0,0 @@ -#!/usr/bin/env perl -package JWebmail::Model::Driver::QMailAuthuser::Extract; - -use v5.18; -use strict; -use warnings; -use utf8; - -use POSIX (); -use JSON::PP; -use Carp; -use List::Util 'min'; -use Encode v2.88 'decode'; - -#use open IO => ':encoding(UTF-8)', ':std'; -no warnings 'experimental::smartmatch'; - -use Mail::Box::Manager; - -use constant ROOT_MAILDIR => '.'; - - -sub main { - my ($maildir) = shift(@ARGV) =~ m/(.*)/; - my ($su) = shift(@ARGV) =~ m/(.*)/; - my ($user) = shift(@ARGV) =~ m/([[:alpha:]]+)/; - my $mode = shift @ARGV; _ok($mode =~ m/([[:alpha:]-]{1,20})/); - my @args = @ARGV; - - delete $ENV{PATH}; - - my $netfehcom_uid = getpwnam($su); - #$> = $netfehcom_uid; - die "won't stay as root" if $netfehcom_uid == 0; - POSIX::setuid($netfehcom_uid); - if ($!) { - warn 'error setting uid'; - exit(1); - } - - my $folder = Mail::Box::Manager->new->open( - folder => "$maildir/$user/", - type => 'maildir', - access => 'rw', - ); - - my $reply = do { - given ($mode) { - when('list') { list($folder, @args) } - when('read-mail') { read_mail($folder, @args) } - when('count') { count_messages($folder, @args) } - when('search') { search($folder, @args) } - when('folders') { folders($folder, @args) } - when('move') { move($folder, @args) } - default { {error => 'unkown mode', mode => $mode} } - } - }; - $folder->close; - - print(encode_json $reply); - if (ref $reply eq 'HASH' && $reply->{error}) { - exit 3; - } -} - - -sub _sort_mails { - my $sort = shift // ''; - my $reverse = 1; - - if ($sort =~ m/^!/) { - $reverse = -1; - $sort = substr $sort, 1; - } - - given ($sort) { - when ('date') { return sub { ($a->timestamp <=> $b->timestamp) * $reverse } } - when ('sender') { return sub { ($a->from->[0] cmp $b->from->[0]) * $reverse } } - when ('subject') { return sub { ($a->subject cmp $b->subject) * $reverse } } - when ('size') { return sub { ($a->size <=> $b->size) * $reverse } } - when ('') { return sub { ($a->timestamp <=> $b->timestamp) * $reverse } } - default { warn "unkown sort-verb '$sort'"; return sub { ($a->timestamp <=> $b->timestamp) * $reverse } } - } -} - - -sub _ok { - if (!shift) { - carp 'verify failed'; - exit 4; - } -} - - -sub list { - my ($f, $start, $end, $sortby, $folder) = @_; - $folder = ".$folder"; - - _ok($start =~ m/^\d+$/); - _ok($end =~ m/^\d+$/); - _ok(0 <= $start && $start <= $end); - _ok($sortby =~ m/^(!?\w+|\w*)$/n); - _ok($folder ~~ [$f->listSubFolders, ROOT_MAILDIR]); - - $f = $f->openSubFolder($folder) if $folder ne ROOT_MAILDIR; - - return [] if $start == $end; - - my $sref = _sort_mails($sortby); - my @msgs = $f->messages; - @msgs = sort { &$sref } @msgs; - @msgs = @msgs[$start..min($#msgs, $end)]; - - my @msgs2; - - for my $msg (@msgs) { - my $msg2 = { - mid => $msg->messageId, - size => $msg->size, - new => $msg->label('seen'), - head => { - subject => decode('MIME-Header', $msg->subject), - from => _addresses($msg->from), - to => _addresses($msg->to), - cc => _addresses($msg->cc), - bcc => _addresses($msg->bcc), - date => _iso8601_utc($msg->timestamp), - content_type => ''.$msg->contentType, - }, - }; - push @msgs2, $msg2; - } - - return \@msgs2; -} - - -sub count_messages { - my ($f, $folder) = @_; - $folder = ".$folder"; - - _ok($folder ~~ [$f->listSubFolders, ROOT_MAILDIR]); - - $f = $f->openSubFolder($folder) if $folder ne ROOT_MAILDIR; - - return { - count => scalar($f->messages('ALL')), - size => $f->size, - new => scalar $f->messages('!seen'), - } -} - - -sub _iso8601_utc { - my @date_time = gmtime(shift); - $date_time[5] += 1900; - $date_time[4]++; - return sprintf('%6$04d-%5$02d-%4$02dT%3$02d:%2$02d:%1$02dZ', @date_time); -} - -sub _unquote { my $x = shift; [$x =~ m/"(.*?)"(?[0] || $x } - -sub _addresses { - [map { {address => $_->address, name => _unquote(decode('MIME-Header', $_->phrase))} } @_] -} - - -sub read_mail { - my ($folder, $mid) = @_; - - my $msg = $folder->find($mid); - return {error => 'no such message', mid => $mid} unless $msg; - return { - size => $msg->size, - head => { - subject => decode('MIME-Header', $msg->subject), - from => _addresses($msg->from), - to => _addresses($msg->to), - cc => _addresses($msg->cc), - bcc => _addresses($msg->bcc), - date => _iso8601_utc($msg->timestamp), - content_type => ''. $msg->contentType, - }, - body => do { - if ($msg->isMultipart) { - [map {{type => ''. $_->contentType, val => '' . $_->decoded}} $msg->body->parts] - } - else { - '' . $msg->body->decoded - } - }, - } -} - - -sub search { - my ($f, $search_pattern, $folder) = @_; - $folder = ".$folder"; - - $f = $f->openSubFolder($folder) if $folder ne ROOT_MAILDIR; - - my @msgs = $f->messages(sub { - my $m = shift; - - return scalar(grep { $_->decoded =~ /$search_pattern/ || (decode('MIME-Header', $_->subject)) =~ /$search_pattern/ } $m->body->parts) - if $m->isMultipart; - $m->body->decoded =~ /$search_pattern/ || (decode('MIME-Header', $m->subject)) =~ /$search_pattern/; - }); - - my @msgs2; - for my $msg (@msgs) { - my $msg2 = { - size => $msg->size, - mid => $msg->messageId, - head => { - subject => decode('MIME-Header', $msg->subject), - from => _addresses($msg->from), - to => _addresses($msg->to), - cc => _addresses($msg->cc), - bcc => _addresses($msg->bcc), - date => _iso8601_utc($msg->timestamp), - content_type => ''. $msg->contentType, - }, - }; - push @msgs2, $msg2; - } - - return \@msgs2; -} - - -sub folders { - my $f = shift; - - return [grep { $_ =~ m/^\./ && $_ =~ s/\.// } $f->listSubFolders]; -} - - -sub move { - my ($f, $mid, $dst) = @_; - $dst = ".$dst"; - - _ok($dst ~~ [$f->listSubFolders, ROOT_MAILDIR]); - - $f->moveMessage($dst, $dst->find($mid)); -} - - -main() if !caller; - -1 - -__END__ - -=encoding utf-8 - -=head1 NAME - -JWebmail::Model::Driver::QMailAuthuser::Extract - Maildir reader - -=head1 SYNOPSIS - -Extract delivers information about emails. -Runs with elevated priviliges. - -=head1 DESCRIPTION - -This programm is started by qmail-authuser with elevated priviliges after -a succsessful login. -Input directives are provided as command line arguments. -Output is delivered via STDOUT and log information via STDERR. - -=head1 ARGUMENTS - - prog - -=head2 Modes - - list - count - read-mail - search - folders - move - -All arguments must be supplied for a given mode even if empty (as ''). - -=head1 DEPENDENCIES - -Currently Mail::Box::Manager does all the hard work. - -=head1 SEE ALSO - -L - -=cut diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser/schema.json b/lib/JWebmail/Model/Driver/QMailAuthuser/schema.json deleted file mode 100644 index b63a5eb..0000000 --- a/lib/JWebmail/Model/Driver/QMailAuthuser/schema.json +++ /dev/null @@ -1,83 +0,0 @@ -{ - "$schema": "http://json-schema.org/schema#", - "definitions": { - "count": { - "type": "object", - "properties": { - "new": {"type": "integer", "minimum": 0}, - "size": {"type": "integer", "minimum": 0}, - "count": {"type": "integer", "minimum": 0}, - "unread": {"type": "integer", "minimum": 0} - }, - "required": ["count"], - "additionalProperties": false - }, - "folders": { - "type": "array", - "items": { - "type": "string" - } - }, - "mail_addrs": { - "type": "array", - "items": { - "type": "object", - "properties": { - "name": {"type": "string"}, - "address": {"type": "string"} - }, - "required": ["address"] - }, - "minItems": 1 - }, - "mail_head": { - "type": "object", - "properties": { - "content_type": {"type": "string"}, - "date": {"type": "string"}, - "cc": {"$ref": "#/definitions/mail_addrs"}, - "bcc": {"$ref": "#/definitions/mail_addrs"}, - "to": {"$ref": "#/definitions/mail_addrs"}, - "from": {"$ref": "#/definitions/mail_addrs"}, - "subject": {"type": "string"} - }, - "required": ["date", "from"] - }, - "head_list": { - "type": "array", - "items": { - "$ref": "#/definitions/mail_head" - } - }, - "mail_body": { - "anyOf": [ - {"type": "string"}, - { - "type": "array", - "minItems": 1, - "items": { - "type": "object", - "properties": { - "head": {"$ref": "#/definitions/mail_head"}, - "body": {"$ref": "#/definitions/mail_body"} - } - } - }, - { - "ref": "#/definitions/mail" - } - ] - }, - "mail": { - "type": "object", - "properties": { - "new": {"type": "boolean"}, - "mid": {"type": "string"}, - "size": {"type": "integer", "minimum": 0}, - "head": {"$ref": "#/definitions/mail_head"}, - "body": {"$ref": "#/definitions/mail_body"} - }, - "required": ["mid"] - } - } -} 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, L, L - -=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 module. + +=cut diff --git a/lib/JWebmail/Model/ReadMails/MockMaildir.pm b/lib/JWebmail/Model/ReadMails/MockMaildir.pm new file mode 100644 index 0000000..31e9618 --- /dev/null +++ b/lib/JWebmail/Model/ReadMails/MockMaildir.pm @@ -0,0 +1,57 @@ +package JWebmail::Model::ReadMails::MockMaildir; + +use Mojo::Base -base; + +use Mojo::JSON 'decode_json'; + + +has user => sub { $ENV{USER} }; +has maildir => 't/'; +has extractor => 'perl'; + + +our %EXTRACTORS = ( + perl => 'perl lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm', + rust => 'extract/target/debug/jwebmail-extract', +); + +use constant { + VALID_USER => 'me@mockmaildir.com', + VALID_PW => '12345', +}; + +sub communicate { + my $self = shift; + my %args = @_; + + if ($args{mode} eq 'auth') { + return ("", 0) if $args{user} eq VALID_USER && $args{password} eq VALID_PW; + return ("", 1); + } + + 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 $pid = open(my $reader, '-|', $exec) + or die 'failed to create subprocess'; + + my $input = <$reader>; + + waitpid($pid, 0); + my $rc = $? >> 8; + + my $resp; + if ($rc == 3 || $rc == 0) { + eval { $resp = decode_json $input; }; + if (my $err = $@) { $resp = {error => "decoding error '$err'"}; $rc ||= 1; }; + } + elsif ($rc) { + $resp = {error => "qmail-authuser returned code: $rc"}; + } + + return ($resp, $rc); +} + + +1 + 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 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. + +=head2 prog + +The path to the extractor programm. +Default is the location of L 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, L + +=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, L, L + +=cut diff --git a/lib/JWebmail/Model/ReadMails/schema.json b/lib/JWebmail/Model/ReadMails/schema.json new file mode 100644 index 0000000..b63a5eb --- /dev/null +++ b/lib/JWebmail/Model/ReadMails/schema.json @@ -0,0 +1,83 @@ +{ + "$schema": "http://json-schema.org/schema#", + "definitions": { + "count": { + "type": "object", + "properties": { + "new": {"type": "integer", "minimum": 0}, + "size": {"type": "integer", "minimum": 0}, + "count": {"type": "integer", "minimum": 0}, + "unread": {"type": "integer", "minimum": 0} + }, + "required": ["count"], + "additionalProperties": false + }, + "folders": { + "type": "array", + "items": { + "type": "string" + } + }, + "mail_addrs": { + "type": "array", + "items": { + "type": "object", + "properties": { + "name": {"type": "string"}, + "address": {"type": "string"} + }, + "required": ["address"] + }, + "minItems": 1 + }, + "mail_head": { + "type": "object", + "properties": { + "content_type": {"type": "string"}, + "date": {"type": "string"}, + "cc": {"$ref": "#/definitions/mail_addrs"}, + "bcc": {"$ref": "#/definitions/mail_addrs"}, + "to": {"$ref": "#/definitions/mail_addrs"}, + "from": {"$ref": "#/definitions/mail_addrs"}, + "subject": {"type": "string"} + }, + "required": ["date", "from"] + }, + "head_list": { + "type": "array", + "items": { + "$ref": "#/definitions/mail_head" + } + }, + "mail_body": { + "anyOf": [ + {"type": "string"}, + { + "type": "array", + "minItems": 1, + "items": { + "type": "object", + "properties": { + "head": {"$ref": "#/definitions/mail_head"}, + "body": {"$ref": "#/definitions/mail_body"} + } + } + }, + { + "ref": "#/definitions/mail" + } + ] + }, + "mail": { + "type": "object", + "properties": { + "new": {"type": "boolean"}, + "mid": {"type": "string"}, + "size": {"type": "integer", "minimum": 0}, + "head": {"$ref": "#/definitions/mail_head"}, + "body": {"$ref": "#/definitions/mail_body"} + }, + "required": ["mid"] + } + } +} -- cgit v1.2.3