1 files changed, 295 insertions, 0 deletions
diff --git a/script/qmauth.pl b/script/qmauth.pl
new file mode 100755
index 0000000..5bc7bb5
--- /dev/null
+++ b/script/qmauth.pl
@@ -0,0 +1,295 @@
+#!/usr/bin/env perl
+package JWebmail::QMAuth;
+
+use v5.18;
+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 <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