From ee43823179ee627ac16ea9da8168e5f1bf9619c0 Mon Sep 17 00:00:00 2001 From: "Jannis M. Hoffmann" Date: Thu, 29 Oct 2020 12:13:04 +0100 Subject: Initial commit; Stable version --- lib/JWebmail/Model/Driver/Mock.pm | 102 +++++++ lib/JWebmail/Model/Driver/QMailAuthuser.pm | 142 ++++++++++ lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm | 293 +++++++++++++++++++++ lib/JWebmail/Model/ReadMails.pm | 227 ++++++++++++++++ lib/JWebmail/Model/WriteMails.pm | 143 ++++++++++ 5 files changed, 907 insertions(+) create mode 100644 lib/JWebmail/Model/Driver/Mock.pm create mode 100644 lib/JWebmail/Model/Driver/QMailAuthuser.pm create mode 100755 lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm create mode 100644 lib/JWebmail/Model/ReadMails.pm create mode 100644 lib/JWebmail/Model/WriteMails.pm (limited to 'lib/JWebmail/Model') diff --git a/lib/JWebmail/Model/Driver/Mock.pm b/lib/JWebmail/Model/Driver/Mock.pm new file mode 100644 index 0000000..eb8c0d0 --- /dev/null +++ b/lib/JWebmail/Model/Driver/Mock.pm @@ -0,0 +1,102 @@ +package JWebmail::Model::Driver::Mock; + +use Mojo::Base -base; + +use List::Util 'sum'; + +use Mojo::JSON qw(decode_json); + + +use constant { + VALID_USER => 'me@example.de', + VALID_PW => 'vwxyz', +}; + +use constant { + LIST_START => 0, + LIST_END => 1, + LIST_SORT => 2, + LIST_FOLDER => 3, +}; + +sub _read_json_file { + my ($file_name) = @_; + + open(my $body_file, '<', $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} cmp $b->{$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 \ No newline at end of file diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser.pm b/lib/JWebmail/Model/Driver/QMailAuthuser.pm new file mode 100644 index 0000000..65e90f1 --- /dev/null +++ b/lib/JWebmail/Model/Driver/QMailAuthuser.pm @@ -0,0 +1,142 @@ +package JWebmail::Model::Driver::QMailAuthuser; + +use Mojo::Base -base; + +use IPC::Open2; +use File::Basename 'fileparse'; +use JSON::PP; + + +has 'user'; +has 'maildir'; +has 'include'; +has qmail_dir => '/var/qmail/'; +has prog => [fileparse(__FILE__)]->[1] . '/QMailAuthuser/Extract.pm'; +has logfile => '/dev/null'; + + +sub communicate { + use autodie; + + 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' + . ' perl ' + . join('', map { ' -I ' . $_ } @{ $self->include }) + . ' -- ' + . 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 + +User name + +=item password + +User password + +=item challenge + +Challenge when using cram + +=back + +=head1 SEE ALSO + +L, L + +=cut \ No newline at end of file diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm b/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm new file mode 100755 index 0000000..30ac4e9 --- /dev/null +++ b/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm @@ -0,0 +1,293 @@ +package JWebmail::Model::Driver::QMailAuthuser::Extract; + +use v5.18; +use strict; +use warnings; +use utf8; + +use POSIX (); +use JSON::PP; +use Carp; +use Encode v2.88 qw(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..$end]; + + my @msgs2; + + for my $msg (@msgs) { + my $msg2 = { + #subject => scalar decode_mimewords($msg->subject), + 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), + size => $msg->size, + content_type => ''. $msg->contentType, + mid => $msg->messageId, + new => $msg->label('seen'), + }; + 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 { + 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), + size => $msg->size, + 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 = shift; + my $search_pattern = shift; + my $folder = shift; + $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 = { + 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), + size => $msg->size, + content_type => ''. $msg->contentType, + mid => $msg->messageId, + }; + push @msgs2, $msg2; + } + + return \@msgs2; +} + + +sub folders { + my $f = shift; + + return [grep { $_ =~ m/^\./ && $_ =~ s/\.// && 1 } $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 \ No newline at end of file diff --git a/lib/JWebmail/Model/ReadMails.pm b/lib/JWebmail/Model/ReadMails.pm new file mode 100644 index 0000000..0f2e1cc --- /dev/null +++ b/lib/JWebmail/Model/ReadMails.pm @@ -0,0 +1,227 @@ +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 recieved 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. + +=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 \ No newline at end of file diff --git a/lib/JWebmail/Model/WriteMails.pm b/lib/JWebmail/Model/WriteMails.pm new file mode 100644 index 0000000..5df5379 --- /dev/null +++ b/lib/JWebmail/Model/WriteMails.pm @@ -0,0 +1,143 @@ +package JWebmail::Model::WriteMails; + +use v5.18; +use warnings; +use utf8; + +use Exporter 'import'; +our @EXPORT_OK = qw(sendmail); +use Data::Dumper; + +use Email::MIME; + + +our $Block_Writes = 0; + + +sub _build_mail { + my $mail = shift; + + my $text_part = Email::MIME->create( + attributes => { + content_type => 'text/plain', + charset => 'utf-8', + encoding => '8bit', + }, + body_str => $mail->{message}, + ); + my $attach; + $attach = Email::MIME->create( + attributes => { + content_type => $mail->{attach_type}, + encoding => 'base64', + }, + body => $mail->{attach}->asset->slurp, + ) if $mail->{attach}; + + my $email = Email::MIME->create( + header_str => [ + From => $mail->{from}, + To => $mail->{to}, + Subject => $mail->{subject}, + 'X-Mailer' => 'JWebmail', + ], + parts => [$text_part, $attach || () ], + ); + $email->header_str_set(CC => @{$mail->{cc}}) if $mail->{cc}; + $email->header_str_set('Reply-To' => $mail->{reply}) if $mail->{reply}; + + return $email->as_string; +} + + +sub _send { + my ($mime, @recipients) = @_; + + open(my $m, '|-', 'sendmail', '-i', @recipients) + or die 'Connecting to sendmail failed. Is it in your PATH?'; + $m->print($mime->as_string); + close($m); + return $? >> 8; +} + + +sub sendmail { + my $mail = shift; + + my $mime = _build_mail($mail); + + my @recipients; + push @recipients, @{ $mail->{to} } if $mail->{to}; + push @recipients, @{ $mail->{cc} } if $mail->{cc}; + push @recipients, @{ $mail->{bcc} } if $mail->{bcc}; + + say $mime if $Block_Writes; + return 1 if $Block_Writes; + + return _send($mime, @recipients); +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +WriteMails - Build and send mails via a sendmail interface + +=head1 SYNOPSIS + + JWebmail::Model::WriteMails::sendmail { + from => ..., + to => ..., + subject => ..., + }; + +=head1 DESCRIPTION + +Build and send mails. + +=head1 FUNCTIONS + +=head2 sendmail + +Send the mail immediately. + +=head3 from + +The sender. + +=head3 to + +The recipient(s). + +=head3 reply + +The address the recipient is meant to reply to (optinal, if missing from is assumed). + +=head3 cc + +Secondary recipients, visible to other. + +=head3 bcc + +Secondary recipients, invisible to other. + +=head3 subject + +=head3 message + +The message body. Should be plain text encoded as utf-8. + +=head3 attach + +Optinal attachment. + +=head3 attach_type + +The mime type of the attachment. + +=cut \ No newline at end of file -- cgit v1.2.3