File Coverage

blib/lib/Sietima/MailStore/FS.pm

Criterion	Covered	Total	%
statement	115	115	100.0
branch	24	42	57.1
condition			n/a
subroutine	19	19	100.0
pod	6	7	85.7
total	164	183	89.6

package Sietima::MailStore::FS;
use Moo;
use Sietima::Policy;
use Types::Path::Tiny qw(Dir);
use Types::Standard qw(Object ArrayRef Str slurpy);
use Type::Params qw(compile);
use Sietima::Types qw(EmailMIME TagName);
use Digest::SHA qw(sha1_hex);
use namespace::clean;

our $VERSION = '1.0.3'; # VERSION
# ABSTRACT: filesystem-backed email store


with 'Sietima::MailStore';


has root => (
    is => 'ro',
    required => 1,
    isa => Dir,
    coerce => 1,
);

has [qw(_tagdir _msgdir)] => ( is => 'lazy' );
sub _build__tagdir($self) { $self->root->child('tags') }
sub _build__msgdir($self) { $self->root->child('msgs') }

sub BUILD($self,@) {
    $self->$_->mkpath for qw(_tagdir _msgdir);
    return;
}


sub store($self,$mail,@tags) {
    state $check = compile(Object,EmailMIME,slurpy ArrayRef[TagName]);$check->(@_);

    my $str = $mail->as_string;
    my $id = sha1_hex($str);

    $self->_msgdir->child($id)->spew_raw($str);

    $self->_tagdir->child($_)->append("$id\n") for @tags;

    return $id;
}


sub retrieve_by_id($self,$id) {
    state $check = compile(Object,Str);$check->(@_);

    my $msg_path = $self->_msgdir->child($id);
    return unless -e $msg_path;
    return Email::MIME->new($msg_path->slurp_raw);
}


sub _tagged_by($self,$tag) {
    my $tag_file = $self->_tagdir->child($tag);
    return unless -e $tag_file;
    return $tag_file->lines({chomp=>1});
}

sub retrieve_ids_by_tags($self,@tags) {
    state $check = compile(Object,slurpy ArrayRef[TagName]);$check->(@_);

    # this maps: id -> how many of the given @tags it has
    my %msgs;
    if (@tags) {
        for my $tag (@tags) {
            $_++ for @msgs{$self->_tagged_by($tag)};
        }
    }
    else {
        $msgs{$_->basename}=0 for $self->_msgdir->children;
    }

    my @ret;
    for my $id (keys %msgs) {
        # if this message id does not have all the required tags, we
        # won't return it
        next unless $msgs{$id} == @tags;
        push @ret, $id;
    }
    return \@ret;
}


sub retrieve_by_tags($self,@tags) {
    state $check = compile(Object,slurpy ArrayRef[TagName]);$check->(@_);

    my @ret;
    for my $id ($self->retrieve_ids_by_tags(@tags)->@*) {
        push @ret, {
            id => $id,
            mail => $self->retrieve_by_id($id),
        };
    }

    return \@ret;
}


sub remove($self,$id) {
    state $check = compile(Object,Str);$check->(@_);

    for my $tag_file ($self->_tagdir->children) {
        $tag_file->edit_lines( sub { $_='' if /\A\Q$id\E\n?\z/ } );
    }
    $self->_msgdir->child($id)->remove;

    return;
}


sub clear($self) {
    do { $self->$_->remove_tree;$self->$_->mkpath } for qw(_tagdir _msgdir);
    return;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Sietima::MailStore::FS - filesystem-backed email store

=head1 VERSION

version 1.0.3

=head1 SYNOPSIS

  my $store = Sietima::MailStore::FS->new({ root => '/tmp/my-store' });

=head1 DESCRIPTION

This class implements the L<< C<Sietima::MailStore> >> interface,
storing emails as files on disk.

=head1 ATTRIBUTES

=head2 C<root>

Required, a L<< C<Path::Tiny> >> object that points to an existing
directory. Coercible from a string.

It's a good idea for the directory to be readable and writable by the
user who will run the mailing list, and also by all users who will run
administrative commands (like those provided by L<<
C<Sietima::Role::SubscriberOnly::Moderate> >>). A way to achieve that
is to have a group dedicated to list owners, and set the directory
group-writable and group-sticky, and owned by that group:

  # chgrp -R mailinglists /tmp/my-store
  # chmod -R g+rwXs /tmp/my-store

=head1 METHODS

=head2 C<store>

  my $id = $store->store($email_mime_object,@tags);

Stores the given email message inside the L<store root|/root>, and
associates with the given tags.

Returns a unique identifier for the stored message. If you store twice
the same message (or two messages that stringify identically), you'll
get the same identifier.

=head2 C<retrieve_by_id>

  my $email_mime_object = $store->retrieve_by_id($id);

Given an identifier returned by L<< /C<store> >>, this method returns
the email message.

If the message has been deleted, or the identifier is not recognised,
this method returns C<undef> in scalar context, or an empty list in
list context.

=head2 C<retrieve_ids_by_tags>

  my @ids = $store->retrieve_ids_by_tags(@tags)->@*;

Given a list of tags, this method returns an arrayref containing the
identifiers of all (and only) the messages that were stored associated
with (at least) all those tags. The order of the returned identifiers
is essentially random.

If there are no messages associated with the given tags, this method
returns an empty arrayref.

=head2 C<retrieve_by_tags>

  my @email_mime_objects = $store->retrieve_by_tags(@tags)->@*;

This method is similar to L<< /C<retrieve_ids_by_tags> >>, but it
returns an arrayref of hashrefs like:

 $store->retrieve_ids_by_tags('t1') ==> [
   { id => $id1, mail => $msg1 },
   { id => $id2, mail => $msg2 },
  ]

=head2 C<remove>

  $store->remove($id);

This method removes the message corresponding to the given identifier
from disk. Removing a non-existent message does nothing.

=head2 C<clear>

  $store->clear();

This method removes all messages from disk. Clearing as empty store
does nothing.

=for Pod::Coverage BUILD

=head1 AUTHOR

Gianni Ceccarelli <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Gianni Ceccarelli <[e-mail]>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut