path: root/lib/Sietima/Role/SubscriberOnly/Moderate.pm

package Sietima::Role::SubscriberOnly::Moderate; 
use Moo::Role;
use Sietima::Policy;
use Email::Stuffer;
use Email::MIME;
use namespace::clean;
 
# VERSION 
# ABSTRACT: moderate messages from non-subscribers 
 
=head1 SYNOPSIS
 
  my $sietima = Sietima->with_traits('SubscribersOnly::Moderate')->new({
    %args,
    owner => 'listmaster@example.com',
    mail_store => {
      class => 'Sietima::MailStore::FS',
      root => '/tmp',
    },
  });
 
=head1 DESCRIPTION
 
A L<< C<Sietima> >> list with this role applied will accept incoming
emails coming from non-subscribers, and store it for moderation. Each
such email will be forwarded (as an attachment) to the list's owner.
 
The owner will the be able to delete the message, or allow it.
 
This is a "sub-role" of L<<
C<SubscribersOnly>|Sietima::Role::SubscriberOnly >>, L<<
C<WithMailStore>|Sietima::Role::WithMailStore >>, and L<<
C<WithOwner>|Sietima::Role::WithOwner >>.
 
=cut
 
with 'Sietima::Role::SubscriberOnly',
    'Sietima::Role::WithMailStore',
    'Sietima::Role::WithOwner';
 
=method C<munge_mail_from_non_subscriber>
 
L<Stores|Sietima::MailStore/store> the email with the C<moderation>
tag, and forwards it to the L<list
owner|Sietima::Role::WithOwner/owner>.
 
=cut
 
sub munge_mail_from_non_subscriber ($self,$mail) {
    my $id = $self->mail_store->store($mail,'moderation');
    my $notice = Email::Stuffer
        ->from($self->return_path->address)
        ->to($self->owner->address)
        ->subject("Message held for moderation - ".$mail->header_str('subject'))
        ->text_body("Use id $id to refer to it")
        ->attach(
            $mail->as_string,
            content_type => 'message/rfc822',
            # some clients, most notably Claws-Mail, seem to have 
            # problems with encodings other than this 
            encoding => '7bit',
        );
    $self->transport->send($notice->email,{
        from => $self->return_path,
        to => [ $self->owner ],
    });
    return;
}
 
=method C<resume>
 
  $sietima->resume($mail_id);
 
Given an identifier returned when L<storing|Sietima::MailStore/store>
an email, this method retrieves the email and re-processes it via L<<
C<ignoring_subscriberonly>|Sietima::Role::SubscriberOnly/ignoring_subscriberonly
>>. This will make sure that the email is not caught again by the
subscriber-only filter.
 
=cut
 
sub resume ($self,$mail_id) {
    my $mail = $self->mail_store->retrieve_by_id($mail_id);
    $self->ignoring_subscriberonly(
        sub($s) { $s->handle_mail($mail) },
    );
    $self->mail_store->remove($mail_id);
}
 
=method C<drop>
 
  $sietima->drop($mail_id);
 
Given an identifier returned when L<storing|Sietima::MailStore/store>
an email, this method deletes the email from the store.
 
=cut
 
sub drop ($self,$mail_id) {
    $self->mail_store->remove($mail_id);
}
 
=method C<list_mails_in_moderation_queue>
 
  $sietima->list_mails_in_moderation_queue($sietima_runner);
 
This method L<retrieves all the
identifiers|Sietima::MailStore/retrieve_by_tags> of messages tagged
C<moderation>, and L<prints them out|App::Spec::Runner/out> via the
L<< C<Sietima::Runner> >> object.
 
This method is usually invoked from the command line, see L<<
/C<command_line_spec> >>.
 
=cut
 
sub list_mails_in_moderation_queue ($self,$runner,@) {
    my $mails = $self->mail_store->retrieve_by_tags('moderation');
    $runner->out(sprintf 'There are %d messages held for moderation:',scalar($mails->@*));
    for my $mail ($mails->@*) {
        $runner->out(sprintf '* %s %s "%s" (%s)',
                     $mail->{id},
                     $mail->{mail}->header_str('From')//'<no from>',
                     $mail->{mail}->header_str('Subject')//'<no subject>',
                     $mail->{mail}->header_str('Date')//'<no date>',
                     );
    }
}
 
=method C<show_mail_from_moderation_queue>
 
  $sietima->show_mail_from_moderation_queue($sietima_runner);
 
This method L<retrieves the email|Sietima::MailStore/retrieve_by_id>
of the message requested from the command line, and L<prints it
out|App::Spec::Runner/out> via the L<< C<Sietima::Runner> >> object.
 
This method is usually invoked from the command line, see L<<
/C<command_line_spec> >>.
 
=cut
 
sub show_mail_from_moderation_queue ($self,$runner,@) {
    my $id = $runner->parameters->{'mail-id'};
    my $mail = $self->mail_store->retrieve_by_id($id);
    $runner->out("Message $id:");
    $runner->out($mail->as_string =~ s{\r\n}{\n}gr);
}
 
=modif C<command_line_spec>
 
This method adds the following sub-commands for the command line:
 
=over
 
=item C<list-held>
 
  $ sietima list-held
 
Invokes the L<< /C<list_mails_in_moderation_queue> >> method, printing
the identifiers of all messages held for moderation.
 
=item C<show-held>
 
  $ sietima show-held 32946p6eu7867
 
Invokes the L<< /C<show_mail_from_moderation_queue> >> method,
printing one message held for moderation; the identifier is expected
as a positional parameter.
 
=item C<resume-held>
 
  $ sietima resume-held 32946p6eu7867
 
Invokes the L<< /C<resume> >> method, causing the held message to be
processed normally; the identifier is expected as a positional
parameter.
 
=item C<drop-held>
 
  $ sietima drop-held 32946p6eu7867
 
Invokes the L<< /C<drop> >> method, removing the held message; the
identifier is expected as a positional parameter.
 
=back
 
=cut
 
around command_line_spec => sub ($orig,$self) {
    my $spec = $self->$orig();
 
    # this allows us to tab-complete identifiers from the shell! 
    my $list_mail_ids = sub ($self,$runner,$args) {
        $self->mail_store->retrieve_ids_by_tags('moderation');
    };
    # a little factoring: $etc->($command_name) generates the spec for 
    # sub-commands that require a mail id 
    my $etc = sub($cmd) {
        return (
            summary => "$cmd the given mail, currently held for moderation",
            parameters => [
                {
                    name => 'mail-id',
                    required => 1,
                    summary => "id of the mail to $cmd",
                    completion => { op => $list_mail_ids },
                },
            ],
        );
    };
 
    $spec->{subcommands}{'list-held'} = {
        op => 'list_mails_in_moderation_queue',
        summary => 'list all mails currently held for moderation',
    };
    $spec->{subcommands}{'show-held'} = {
        op => 'show_mail_from_moderation_queue',
        $etc->('show'),
    };
    $spec->{subcommands}{'resume-held'} = {
        op => sub ($self,$runner,$args) {
            $self->resume($runner->parameters->{'mail-id'});
        },
        $etc->('resume'),
    };
    $spec->{subcommands}{'drop-held'} = {
        op => sub ($self,$runner,$args) {
            $self->drop($runner->parameters->{'mail-id'});
        },
        $etc->('drop'),
    };
 
    return $spec;
};
 
1;