path: root/script/qmauth.pl

#!/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