renamed qmauth to extract

1 files changed, 310 insertions, 0 deletions

diff --git a/script/extract.pl b/script/extract.pl
new file mode 100755
index 0000000..000eaa0
--- /dev/null
+++ b/script/extract.pl
@@ -0,0 +1,310 @@
+#!/usr/bin/env perl
+package JWebmail::QMAuth;
+
+use v5.18;
+use warnings;
+use utf8;
+
+use Carp;
+use Encode v2.88 'decode';
+use JSON::PP;
+use List::Util 'min';
+use POSIX 'setuid';
+
+#use open IO => ':encoding(UTF-8)', ':std';
+
+use Mail::Box::Maildir;
+
+
+package JWebmail::QMAuth::Message::Head::Complete {
+    use parent 'Mail::Message::Head::Complete';
+
+    use File::Basename;
+
+    sub createMessageId {
+        my $self = shift;
+
+        my ($mid) = scalar(fileparse($self->message->filename)) =~ /(.+):/;
+        return $mid || $self->SUPER::createMessageId;
+    }
+}
+
+
+sub main {
+    my ($maildir, $su, $user, $mode, @args) = @ARGV;
+
+    delete $ENV{PATH};
+
+    my $netfehcom_uid = getpwnam($su);
+    die "won't stay as root" if $netfehcom_uid == 0;
+    setuid($netfehcom_uid);
+    if ($!) {
+        warn 'error setting uid';
+        exit(1);
+    }
+
+    my $folder = Mail::Box::Maildir->new(
+        folder    => "$maildir/$user/",
+        type      => 'maildir',
+        access    => 'rw',
+        head_type => 'JWebmail::QMAuth::Message::Head::Complete',
+    );
+
+    my $reply = do {
+        if    ($mode eq 'list')    { list($folder, @args) }
+        elsif ($mode eq 'read')    { read_mail($folder, @args) }
+        elsif ($mode eq 'count')   { count_messages($folder, @args) }
+        elsif ($mode eq 'search')  { search($folder, @args) }
+        elsif ($mode eq 'folders') { folders($folder, @args) }
+        elsif ($mode eq 'move')    { move($folder, @args) }
+        else                       { {error => 'unknown mode', mode => $mode} }
+    };
+    $folder->close;
+
+    print(encode_json $reply);
+    if (ref $reply eq 'HASH' && $reply->{error}) {
+        exit 3;
+    }
+}
+
+
+sub _sort_mails {
+    my ($sort) = @_;
+
+    my $reverse = '';
+    if ($sort =~ /^!/) {
+        $reverse = 1;
+        $sort = substr $sort, 1;
+    }
+
+    my $sortsub = do {
+        if    ($sort eq 'date')    { sub { $a->timestamp <=> $b->timestamp } }
+        elsif ($sort eq 'sender')  { sub { $a->from->[0] cmp $b->from->[0] } }
+        elsif ($sort eq 'subject') { sub { $a->subject cmp $b->subject } }
+        elsif ($sort eq 'size')    { sub { $a->size <=> $b->size } }
+        elsif ($sort eq '')        { sub { $a->timestamp <=> $b->timestamp } }
+        else {
+            warn "unknown sort-verb '$sort'";
+            sub { $a->timestamp <=> $b->timestamp }
+        }
+    };
+    return $reverse ? sub { $sortsub->() * -1 } : $sortsub;
+}
+
+
+sub _ok {
+    if (!shift) {
+        carp 'verify failed';
+        exit 4;
+    }
+}
+
+
+sub _get_mime_head_info {
+    my ($msg) = @_;
+
+    return {
+        content_maintype    => $msg->body->mimeType->mediaType,
+        content_subtype     => $msg->body->mimeType->subType,
+        content_disposition => ''.$msg->body->disposition,
+        filename            => $msg->body->dispositionFilename,
+    };
+}
+
+
+sub _get_head_info {
+    my ($msg) = @_;
+
+    return {
+        date => _iso8601_utc($msg->timestamp),
+
+        from   => _addresses($msg->from),
+        sender => _addresses($msg->sender),
+
+        to  => _addresses($msg->to),
+        cc  => _addresses($msg->cc),
+        bcc => _addresses($msg->bcc),
+
+        subject  => decode('MIME-Header', $msg->subject),
+        comments => $msg->get('comments'),
+        keywords => $msg->get('keywords'),
+
+        mime => _get_mime_head_info($msg),
+    };
+}
+
+
+sub list {
+    my ($f, $folder, $start, $end, $sortby) = @_;
+
+    _ok($start =~ /^\d+$/aa);
+    _ok($end =~ /^\d+$/aa);
+    _ok(0 <= $start && $start <= $end);
+    _ok($sortby =~ /^(?:!?\w+|)$/aa);
+    _ok(!$folder || grep { $_ eq ".$folder" } $f->listSubFolders);
+
+    $f = $f->openSubFolder(".$folder") if $folder;
+
+    return [] if $start == $end;
+
+    my $sref = _sort_mails($sortby);
+    my @msgs = $f->messages;
+    @msgs = sort { &$sref } @msgs;
+    @msgs = @msgs[$start..min($#msgs, $end-1)];
+
+    return [map {
+        {
+            byte_size      => $_->size,
+            unread         => !$_->label('seen'),
+            date_received  => $_->guessTimestamp,
+            message_handle => $_->messageId,
+            head           => _get_head_info($_),
+        }
+    } @msgs];
+}
+
+
+sub count_messages {
+    my ($f, $folder) = @_;
+
+    $f = $f->openSubFolder(".$folder") if $folder;
+
+    return {
+        total_mails  => scalar $f->messages('ALL'),
+        byte_size    => $f->size,
+        unread_mails => 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 {
+    return undef unless @_;
+    [map { {address => $_->address, name => _unquote(decode('MIME-Header', $_->phrase))} } @_]
+}
+
+
+sub _get_body {
+    my ($msg) = @_;
+
+    if ($msg->isNested) {
+        my $nested = $msg->body->nested;
+        return {
+            head => _get_head_info($nested),
+            body => _get_body($nested),
+        };
+    }
+    elsif ($msg->isMultipart) {
+        return {
+            preamble => ''.$msg->body->preamble,
+            parts    => [map { { head => _get_mime_head_info($_), body => _get_body($_) } } $msg->parts],
+            epilogue => $msg->body->epilogue,
+        }
+    }
+    else {
+        return ''.$msg->decoded;
+    }
+}
+
+
+sub read_mail {
+    my ($f, $folder, $mid) = @_;
+
+    $f = $folder->openSubFolder(".$folder") if $folder;
+
+    my $msg = $f->find($mid);
+    return {error => 'no such message', mid => $mid} unless $msg;
+    return {
+        head => _get_head_info($msg),
+        body => _get_body($msg),
+    }
+}
+
+
+sub search {
+    my ($f, $search_pattern, $folder) = @_;
+
+    $f = $f->openSubFolder(".$folder") if $folder;
+
+    my @msgs = $f->messages(sub {
+        my ($m) = @_;
+
+        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 = {
+            head => _get_head_info($msg),
+            body => '',
+        };
+        push @msgs2, $msg2;
+    }
+
+    return \@msgs2;
+}
+
+
+sub folders {
+    my $f = shift;
+
+    return [map { s/^\.//r } $f->listSubFolders(check => 1)];
+}
+
+
+sub move {
+    my ($f, $mid, $from, $to) = @_;
+
+    $f = $f->openSubFolder(".$from") if $from;
+
+    $f->find($mid)->moveTo($to ? ".$to" : $to);
+
+    return 1;
+}
+
+
+main unless 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.
+
+For the implemented interface see the README file.
+
+=head1 DEPENDENCIES
+
+Currently Mail::Box::Manager does all the hard work.
+
+=head1 SEE ALSO
+
+L<JWebmail::Model::ReadMails::QMailAuthuser>
+
+=cut