path: root/lib/Sietima/MailStore/FS.pm

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 -sigs;
use Sietima::Types qw(EmailMIME TagName);
use Digest::SHA qw(sha1_hex);
use namespace::clean;
 
# VERSION 
# ABSTRACT: filesystem-backed email store 
 
=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.
 
=cut
 
with 'Sietima::MailStore';
 
=attr 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
 
=for Pod::Coverage BUILD
 
=cut
 
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;
}
 
=method 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.
 
=cut
 
signature_for store => (
    method => Object,
    positional => [
        EmailMIME,
        Slurpy[ArrayRef[TagName]],
    ],
);
sub store($self,$mail,$tags) {
 
    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;
}
 
=method 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.
 
=cut
 
signature_for retrieve_by_id => (
    method => Object,
    positional => [ Str ],
);
sub retrieve_by_id($self,$id) {
    my $msg_path = $self->_msgdir->child($id);
    return unless -e $msg_path;
    return Email::MIME->new($msg_path->slurp_raw);
}
 
=method 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.
 
=cut
 
sub _tagged_by($self,$tag) {
    my $tag_file = $self->_tagdir->child($tag);
    return unless -e $tag_file;
    return $tag_file->lines({chomp=>1});
}
 
signature_for retrieve_ids_by_tags => (
    method => Object,
    positional => [
        Slurpy[ArrayRef[TagName]],
    ],
);
sub retrieve_ids_by_tags($self,$tags) {
    # 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;
}
 
=method 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 },
  ]
 
=cut
 
signature_for retrieve_by_tags => (
    method => Object,
    positional => [
        Slurpy[ArrayRef[TagName]],
    ],
);
sub retrieve_by_tags($self,$tags) {
    my @ret;
    for my $id ($self->retrieve_ids_by_tags($tags->@*)->@*) {
        push @ret, {
            id => $id,
            mail => $self->retrieve_by_id($id),
        };
    }
 
    return \@ret;
}
 
=method C<remove>
 
  $store->remove($id);
 
This method removes the message corresponding to the given identifier
from disk. Removing a non-existent message does nothing.
 
=cut
 
signature_for remove => (
    method => Object,
    positional => [ Str ],
);
sub remove($self,$id) {
    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;
}
 
=method C<clear>
 
  $store->clear();
 
This method removes all messages from disk. Clearing as empty store
does nothing.
 
 
=cut
 
sub clear($self) {
    do { $self->$_->remove_tree;$self->$_->mkpath } for qw(_tagdir _msgdir);
    return;
}
 
1;