Refactored ReadMails into a role

5 files changed, 655 insertions, 0 deletions

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/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<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/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"]
+    }
+  }
+}