Initial commit; Stable version

3 files changed, 537 insertions, 0 deletions

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<JWebmail::Model::ReadMails> 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<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
+
+User name
+
+=item password
+
+User password
+
+=item challenge
+
+Challenge when using cram
+
+=back
+
+=head1 SEE ALSO
+
+L<JWebmail::Model::ReadMails>, L<JWebmail::Model::Driver::QMailAuthuser::Extract>
+
+=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 <maildir> <system-user> <mail-user> <mode> <args...>
+
+=head2 Modes
+
+  list <start> <end> <sort-by> <folder>
+  count <folder>
+  read-mail <mid>
+  search <pattern> <folder>
+  folders
+  move <mid> <dst-folder>
+
+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<JWebmail::Model::Driver::QMailAuthuser>
+
+=cut
\ No newline at end of file