diff options
Diffstat (limited to 'lib')
25 files changed, 364 insertions, 150 deletions
diff --git a/lib/Sietima.pm b/lib/Sietima.pm index a5d22d9..3152ac8 100644 --- a/lib/Sietima.pm +++ b/lib/Sietima.pm @@ -1,8 +1,8 @@ package Sietima; use Moo; use Sietima::Policy; -use Types::Standard qw(ArrayRef Object FileHandle Maybe); -use Type::Params qw(compile); +use Types::Standard qw(ArrayRef Object); +use Type::Params -sigs; use Sietima::Types qw(Address AddressFromStr EmailMIME Message Subscriber SubscriberFromAddress SubscriberFromStr SubscriberFromHashRef @@ -10,12 +10,11 @@ use Sietima::Types qw(Address AddressFromStr use Sietima::Message; use Sietima::Subscriber; use Email::Sender::Simple qw(); -use Email::Sender; use Email::Address; use namespace::clean; with 'MooX::Traits'; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: minimal mailing list manager @@ -58,9 +57,11 @@ sub handle_mail_from_stdin($self,@) { } +signature_for handle_mail => ( + method => Object, + positional => [ EmailMIME ], +); sub handle_mail($self,$incoming_mail) { - state $check = compile(Object,EmailMIME); $check->(@_); - my (@outgoing_messages) = $self->munge_mail($incoming_mail); for my $outgoing_message (@outgoing_messages) { $self->send_message($outgoing_message); @@ -69,16 +70,20 @@ sub handle_mail($self,$incoming_mail) { } +signature_for subscribers_to_send_to => ( + method => Object, + positional => [ EmailMIME ], +); sub subscribers_to_send_to($self,$incoming_mail) { - state $check = compile(Object,EmailMIME); $check->(@_); - return $self->subscribers; } +signature_for munge_mail => ( + method => Object, + positional => [ EmailMIME ], +); sub munge_mail($self,$incoming_mail) { - state $check = compile(Object,EmailMIME); $check->(@_); - return Sietima::Message->new({ mail => $incoming_mail, from => $self->return_path, @@ -87,9 +92,11 @@ sub munge_mail($self,$incoming_mail) { } +signature_for send_message => ( + method => Object, + positional => [ Message ], +); sub send_message($self,$outgoing_message) { - state $check = compile(Object,Message); $check->(@_); - my $envelope = $outgoing_message->envelope; if ($envelope->{to} && $envelope->{to}->@*) { $self->transport->send( @@ -138,7 +145,7 @@ Sietima - minimal mailing list manager =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -188,6 +195,10 @@ specifies that to (un)subscribe, people should write to the list owner avoids sending messages to subscribers who don't want them +=item L<< C<NoSpoof>|Sietima::Role::NoSpoof >> + +replaces the C<From> address with the list's own address + =item L<< C<ReplyTo>|Sietima::Role::ReplyTo >> optionally sets the C<Reply-To> header to the mailing list address @@ -231,7 +242,7 @@ empty array. Each item can be coerced from a string or a L<< C<Email::Address> >> instance, or a hashref of the form - { address => $string, %other_attributes } + { primary => $string, %other_attributes } The base Sietima class only uses the address of subscribers, but some roles use the other attributes (L<< C<NoMail>|Sietima::Role::NoMail @@ -343,7 +354,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/CmdLine.pm b/lib/Sietima/CmdLine.pm index a3a7583..68bc75c 100644 --- a/lib/Sietima/CmdLine.pm +++ b/lib/Sietima/CmdLine.pm @@ -8,7 +8,7 @@ use App::Spec; use Sietima::Runner; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: run Sietima as a command-line application @@ -83,7 +83,7 @@ Sietima::CmdLine - run Sietima as a command-line application =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -169,7 +169,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/HeaderURI.pm b/lib/Sietima/HeaderURI.pm index 323b075..9834f62 100644 --- a/lib/Sietima/HeaderURI.pm +++ b/lib/Sietima/HeaderURI.pm @@ -3,12 +3,12 @@ use Moo; use Sietima::Policy; use Sietima::Types qw(Address AddressFromStr is_Address); use Types::Standard qw(Str is_Str ClassName HashRef Optional); -use Type::Params qw(compile); +use Type::Params -sigs; use Types::URI qw(Uri is_Uri); use Email::Address; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: annotated URI for list headers @@ -26,10 +26,7 @@ has comment => ( ); -sub _args_from_address { - my ($address, $query) = @_; - $query ||= {}; - +sub _args_from_address($address, $query={}) { my $uri = URI->new($address->address,'mailto'); $uri->query_form($query->%*); @@ -44,8 +41,7 @@ sub _args_from_address { }; } -around BUILDARGS => sub { - my ($orig, $class, @args) = @_; +around BUILDARGS => sub($orig, $class, @args) { if (@args != 1 or ref($args[0]) eq 'HASH' and $args[0]->{uri}) { return $class->$orig(@args); } @@ -66,21 +62,19 @@ around BUILDARGS => sub { }; -sub new_from_address { - state $check = compile( - ClassName, +signature_for new_from_address => ( + method => Str, + positional => [ Address->plus_coercions(AddressFromStr), Optional[HashRef], - ); - my ($class, $address, $query) = $check->(@_); - + ], +); +sub new_from_address($class, $address, $query={}) { return $class->new(_args_from_address($address,$query)); } -sub as_header_raw { - my ($self) = @_; - +sub as_header_raw($self) { my $str = sprintf '<%s>',$self->uri; if (my $c = $self->comment) { $str .= sprintf ' (%s)',$c; @@ -103,7 +97,7 @@ Sietima::HeaderURI - annotated URI for list headers =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -226,7 +220,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/MailStore.pm b/lib/Sietima/MailStore.pm index 543ff43..74d5ce4 100644 --- a/lib/Sietima/MailStore.pm +++ b/lib/Sietima/MailStore.pm @@ -3,7 +3,7 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: interface for mail stores @@ -25,7 +25,7 @@ Sietima::MailStore - interface for mail stores =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 DESCRIPTION @@ -89,7 +89,7 @@ return an arrayref of hashrefs. For example: my $id2 = $ms->store($msg2,'t2'); my $id3 = $ms->store($msg3,'t1','t2'); - $ms->retrieve_ids_by_tags('t1') ==> [ + $ms->retrieve_by_tags('t1') ==> [ { id => $id3, mail => $msg3 }, { id => $id1, mail => $msg1 }, ] @@ -115,7 +115,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/MailStore/FS.pm b/lib/Sietima/MailStore/FS.pm index b829a0a..6479ea3 100644 --- a/lib/Sietima/MailStore/FS.pm +++ b/lib/Sietima/MailStore/FS.pm @@ -2,13 +2,13 @@ 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 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; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: filesystem-backed email store @@ -32,23 +32,31 @@ sub BUILD($self,@) { } -sub store($self,$mail,@tags) { - state $check = compile(Object,EmailMIME,slurpy ArrayRef[TagName]);$check->(@_); +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; + $self->_tagdir->child($_)->append("$id\n") for $tags->@*; return $id; } +signature_for retrieve_by_id => ( + method => Object, + positional => [ Str ], +); 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); @@ -61,13 +69,17 @@ sub _tagged_by($self,$tag) { return $tag_file->lines({chomp=>1}); } -sub retrieve_ids_by_tags($self,@tags) { - state $check = compile(Object,slurpy ArrayRef[TagName]);$check->(@_); - +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) { + if ($tags->@*) { + for my $tag ($tags->@*) { $_++ for @msgs{$self->_tagged_by($tag)}; } } @@ -79,18 +91,22 @@ sub retrieve_ids_by_tags($self,@tags) { 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; + next unless $msgs{$id} == $tags->@*; push @ret, $id; } return \@ret; } -sub retrieve_by_tags($self,@tags) { - state $check = compile(Object,slurpy ArrayRef[TagName]);$check->(@_); - +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)->@*) { + for my $id ($self->retrieve_ids_by_tags($tags->@*)->@*) { push @ret, { id => $id, mail => $self->retrieve_by_id($id), @@ -101,9 +117,11 @@ sub retrieve_by_tags($self,@tags) { } +signature_for remove => ( + method => Object, + positional => [ Str ], +); 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/ } ); } @@ -132,7 +150,7 @@ Sietima::MailStore::FS - filesystem-backed email store =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -167,7 +185,7 @@ group-writable and group-sticky, and owned by that group: 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. +associates it 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 @@ -203,7 +221,7 @@ returns an empty arrayref. 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') ==> [ + $store->retrieve_by_tags('t1') ==> [ { id => $id1, mail => $msg1 }, { id => $id2, mail => $msg2 }, ] @@ -230,7 +248,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Message.pm b/lib/Sietima/Message.pm index d5d2b04..3ced3f5 100644 --- a/lib/Sietima/Message.pm +++ b/lib/Sietima/Message.pm @@ -10,7 +10,7 @@ use Sietima::Subscriber; use Email::MIME; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: an email message with an envelope @@ -64,7 +64,7 @@ Sietima::Message - an email message with an envelope =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -117,7 +117,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Policy.pm b/lib/Sietima/Policy.pm index 5ac4b6f..68d7666 100644 --- a/lib/Sietima/Policy.pm +++ b/lib/Sietima/Policy.pm @@ -1,11 +1,10 @@ package Sietima::Policy; -use 5.024; +use v5.36; use strict; use warnings; -use feature ':5.24'; -use experimental 'signatures'; +use feature ':5.36'; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: pragma for Sietima modules @@ -14,8 +13,7 @@ sub import { # so no need for import::into strict->import; warnings->import; - experimental->import('signatures'); - feature->import(':5.24'); + feature->import(':5.36'); return; } @@ -33,15 +31,14 @@ Sietima::Policy - pragma for Sietima modules =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS - use 5.024; + use v5.36; use strict; use warnings; - use feature ':5.24'; - use experimental 'signatures'; + use feature ':5.36'; or just: @@ -58,7 +55,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/AvoidDups.pm b/lib/Sietima/Role/AvoidDups.pm index 3fe6182..10df404 100644 --- a/lib/Sietima/Role/AvoidDups.pm +++ b/lib/Sietima/Role/AvoidDups.pm @@ -4,7 +4,7 @@ use Sietima::Policy; use Email::Address; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: prevent people from receiving the same message multiple times @@ -39,7 +39,7 @@ Sietima::Role::AvoidDups - prevent people from receiving the same message multip =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -65,7 +65,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/Debounce.pm b/lib/Sietima/Role/Debounce.pm index 129fcff..a1ee547 100644 --- a/lib/Sietima/Role/Debounce.pm +++ b/lib/Sietima/Role/Debounce.pm @@ -3,7 +3,7 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: avoid mail loops @@ -36,7 +36,7 @@ Sietima::Role::Debounce - avoid mail loops =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -65,7 +65,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/Headers.pm b/lib/Sietima/Role/Headers.pm index 2547b70..f6ad9af 100644 --- a/lib/Sietima/Role/Headers.pm +++ b/lib/Sietima/Role/Headers.pm @@ -1,14 +1,12 @@ package Sietima::Role::Headers; use Moo::Role; -use Try::Tiny; use Sietima::Policy; use Sietima::HeaderURI; -use Email::Address; use Types::Standard qw(Str); use Sietima::Types qw(HeaderUriFromThings); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: adds standard list-related headers to messages @@ -89,7 +87,7 @@ Sietima::Role::Headers - adds standard list-related headers to messages =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -174,7 +172,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/ManualSubscription.pm b/lib/Sietima/Role/ManualSubscription.pm index ebda9c9..0b86642 100644 --- a/lib/Sietima/Role/ManualSubscription.pm +++ b/lib/Sietima/Role/ManualSubscription.pm @@ -4,7 +4,7 @@ use Sietima::Policy; use Sietima::HeaderURI; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: adds standard list-related headers to messages with 'Sietima::Role::WithOwner'; @@ -41,7 +41,7 @@ Sietima::Role::ManualSubscription - adds standard list-related headers to messag =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -74,7 +74,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/NoMail.pm b/lib/Sietima/Role/NoMail.pm index 6d46a3d..160650a 100644 --- a/lib/Sietima/Role/NoMail.pm +++ b/lib/Sietima/Role/NoMail.pm @@ -3,7 +3,7 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: don't send mail to those who don't want it @@ -28,7 +28,7 @@ Sietima::Role::NoMail - don't send mail to those who don't want it =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -59,7 +59,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/NoSpoof.pm b/lib/Sietima/Role/NoSpoof.pm new file mode 100644 index 0000000..e26bed9 --- /dev/null +++ b/lib/Sietima/Role/NoSpoof.pm @@ -0,0 +1,69 @@ +package Sietima::Role::NoSpoof; +use Moo::Role; +use Sietima::Policy; +use Email::Address; +use namespace::clean; + +our $VERSION = '1.1.3'; # VERSION +# ABSTRACT: never sends out messages from subscribers' addresses + + +with 'Sietima::Role::WithPostAddress'; + +around munge_mail => sub ($orig,$self,$incoming_mail) { + my $sender = $self->post_address->address; + my ($from) = Email::Address->parse($incoming_mail->header_str('From')); + + if ($from->host ne $self->post_address->host) { + $from->address($sender); + + $incoming_mail->header_str_set( + From => $from, + ); + } + + return $self->$orig($incoming_mail); +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::NoSpoof - never sends out messages from subscribers' addresses + +=head1 VERSION + +version 1.1.3 + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('NoSpoof')->new(\%args); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will replace the +C<From> address with its own L<< +C<post_address>|Sietima::Role::WithPostAddress >> (this is a +"sub-role" of L<< C<WithPostAddress>|Sietima::Role::WithPostAddress +>>) I<if> the C<From> is on a different domain. + +This will make the list DMARC-compliant. + +=head1 AUTHOR + +Gianni Ceccarelli <dakkar@thenautilus.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +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 diff --git a/lib/Sietima/Role/NoSpoof/DMARC.pm b/lib/Sietima/Role/NoSpoof/DMARC.pm new file mode 100644 index 0000000..78e382a --- /dev/null +++ b/lib/Sietima/Role/NoSpoof/DMARC.pm @@ -0,0 +1,124 @@ +package Sietima::Role::NoSpoof::DMARC; +use Moo::Role; +use Sietima::Policy; +use Email::Address; +use Mail::DMARC::PurePerl; +use namespace::clean; + +our $VERSION = '1.1.3'; # VERSION +# ABSTRACT: send out messages from subscribers' addresses only if DMARC allows it + + +with 'Sietima::Role::WithPostAddress'; + +# mostly for testing +has dmarc_resolver => ( is => 'ro' ); + +around munge_mail => sub ($orig,$self,$incoming_mail) { + my $sender = $self->post_address->address; + my ($from) = Email::Address->parse($incoming_mail->header_str('From')); + my $from_domain = $from->host; + + if ($from_domain ne $self->post_address->host) { + my $dmarc = Mail::DMARC::PurePerl->new( + resolver => $self->dmarc_resolver, + ); + $dmarc->header_from($from_domain); + + if (my $policy = $dmarc->discover_policy) { + # sp applies to sub-domains, defaults to p; p applies to + # the domain itself, and is required + my $relevant_value = $dmarc->is_subdomain + ? ( $policy->sp // $policy->p ) + : $policy->p; + + if ($relevant_value ne 'none') { + $incoming_mail->header_str_set( + 'Original-From' => $from, + ); + + $from->address($sender); + + $incoming_mail->header_str_set( + From => $from, + ); + + return $self->$orig($incoming_mail); + } + } + } + + $incoming_mail->header_str_set( + Sender => $sender, + ) if $sender ne $from->address; + + return $self->$orig($incoming_mail); + +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sietima::Role::NoSpoof::DMARC - send out messages from subscribers' addresses only if DMARC allows it + +=head1 VERSION + +version 1.1.3 + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits('NoSpoof::DMARC')->new(\%args); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role applied will replace the +C<From> address with its own L<< +C<post_address>|Sietima::Role::WithPostAddress >> (this is a +"sub-role" of L<< C<WithPostAddress>|Sietima::Role::WithPostAddress +>>) I<if> the C<From> is on a different domain and the originating +address's DMARC policy requires it. + +This will make the list DMARC-compliant while minimising the changes +to the messages. + +The original C<From> address will be preserved in the C<Original-From> +header, as required by RFC 5703. + +=head2 Some more details + +DMARC requires L<"identifier +alignment"|https://datatracker.ietf.org/doc/html/rfc7489#section-3.1>, +essentially the C<MAIL FROM> (envelope) and the header C<From> must +have the same domain (or at least belong to the same "organisational +domain", i.e. be both under a common non-top-level domain, roughly). + +Therefore, a mailing list that forwards a message sent from a +DMARC-enabled domain, I<must> rewrite the C<From> header, otherwise +the message will be discarded by recipient servers. If the originating +domain does not publish a DMARC policy (or publishes a C<none> +policy), the mailing list can leave the C<From> as is, but should add +a C<Sender> header with the list's own address. + +This role does exactly that. + +=for Pod::Coverage dmarc_resolver + +=head1 AUTHOR + +Gianni Ceccarelli <dakkar@thenautilus.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. + +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 diff --git a/lib/Sietima/Role/ReplyTo.pm b/lib/Sietima/Role/ReplyTo.pm index f790842..ca1c6fc 100644 --- a/lib/Sietima/Role/ReplyTo.pm +++ b/lib/Sietima/Role/ReplyTo.pm @@ -2,11 +2,10 @@ package Sietima::Role::ReplyTo; use Moo::Role; use Sietima::Policy; use Types::Standard qw(Bool); -use Sietima::Types qw(Address AddressFromStr); use List::AllUtils qw(part); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: munge the C<Reply-To> header @@ -77,7 +76,7 @@ Sietima::Role::ReplyTo - munge the C<Reply-To> header =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -142,7 +141,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/SubjectTag.pm b/lib/Sietima/Role/SubjectTag.pm index ac3f71c..04e9b1c 100644 --- a/lib/Sietima/Role/SubjectTag.pm +++ b/lib/Sietima/Role/SubjectTag.pm @@ -4,7 +4,7 @@ use Sietima::Policy; use Types::Standard qw(Str); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: add a tag to messages' subjects @@ -40,7 +40,7 @@ Sietima::Role::SubjectTag - add a tag to messages' subjects =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -80,7 +80,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/SubscriberOnly.pm b/lib/Sietima/Role/SubscriberOnly.pm index 41002f3..5502def 100644 --- a/lib/Sietima/Role/SubscriberOnly.pm +++ b/lib/Sietima/Role/SubscriberOnly.pm @@ -4,10 +4,10 @@ use Sietima::Policy; use Email::Address; use List::AllUtils qw(any); use Types::Standard qw(Object CodeRef); -use Type::Params qw(compile); +use Type::Params -sigs; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: base role for "closed" lists @@ -28,9 +28,11 @@ around munge_mail => sub ($orig,$self,$mail) { }; +signature_for ignoring_subscriberonly => ( + method => Object, + positional => [ CodeRef ], +); sub ignoring_subscriberonly($self,$code) { - state $check = compile(Object,CodeRef); $check->(@_); - local $let_it_pass = 1; return $code->($self); } @@ -49,7 +51,7 @@ Sietima::Role::SubscriberOnly - base role for "closed" lists =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -79,9 +81,10 @@ C<Sietima::Role::SubscriberOnly::Moderate> >> for useable roles. This method will be invoked from L<< C<munge_mail>|Sietima/munge_mail >> whenever an email is processed that does not come from one of the list's subscribers. This method should return a (possibly empty) list -of L<< C<Sietima::Message> >> objects, just like C<munge_mail>. It can -also have side-effects, like forwarding the email to the owner of the -list. +of L<< C<Sietima::Message> >> objects, just like C<munge_mail>, for +example to forward the email to the owner of the list. It can also +have side-effects, like storing a copy of the message to approve +later. =head1 METHODS @@ -111,7 +114,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/SubscriberOnly/Drop.pm b/lib/Sietima/Role/SubscriberOnly/Drop.pm index bfe7afb..8991043 100644 --- a/lib/Sietima/Role/SubscriberOnly/Drop.pm +++ b/lib/Sietima/Role/SubscriberOnly/Drop.pm @@ -3,7 +3,7 @@ use Moo::Role; use Sietima::Policy; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: drop messages from non-subscribers @@ -26,7 +26,7 @@ Sietima::Role::SubscriberOnly::Drop - drop messages from non-subscribers =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -55,7 +55,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/SubscriberOnly/Moderate.pm b/lib/Sietima/Role/SubscriberOnly/Moderate.pm index ec7454a..c141ca0 100644 --- a/lib/Sietima/Role/SubscriberOnly/Moderate.pm +++ b/lib/Sietima/Role/SubscriberOnly/Moderate.pm @@ -2,10 +2,9 @@ package Sietima::Role::SubscriberOnly::Moderate; use Moo::Role; use Sietima::Policy; use Email::Stuffer; -use Email::MIME; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: moderate messages from non-subscribers @@ -28,11 +27,12 @@ sub munge_mail_from_non_subscriber ($self,$mail) { # problems with encodings other than this encoding => '7bit', ); - $self->transport->send($notice->email,{ + + return Sietima::Message->new({ + mail => $notice->email, from => $self->return_path, to => [ $self->owner ], }); - return; } @@ -139,7 +139,7 @@ Sietima::Role::SubscriberOnly::Moderate - moderate messages from non-subscribers =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -177,8 +177,9 @@ owner|Sietima::Role::WithOwner/owner>. $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<< +Given the identifier returned when +L<storing|Sietima::MailStore/store>-ing 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. @@ -187,8 +188,9 @@ subscriber-only filter. $sietima->drop($mail_id); -Given an identifier returned when L<storing|Sietima::MailStore/store> -an email, this method deletes the email from the store. +Given the identifier returned when +L<storing|Sietima::MailStore/store>-ing an email, this method deletes +the email from the store. =head2 C<list_mails_in_moderation_queue> @@ -280,7 +282,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/WithMailStore.pm b/lib/Sietima/Role/WithMailStore.pm index c0cf995..6b71a7a 100644 --- a/lib/Sietima/Role/WithMailStore.pm +++ b/lib/Sietima/Role/WithMailStore.pm @@ -4,7 +4,7 @@ use Sietima::Policy; use Sietima::Types qw(MailStore MailStoreFromHashRef); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: role for lists with a store for messages @@ -29,7 +29,7 @@ Sietima::Role::WithMailStore - role for lists with a store for messages =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -65,7 +65,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/WithOwner.pm b/lib/Sietima/Role/WithOwner.pm index 1793381..69d8637 100644 --- a/lib/Sietima/Role/WithOwner.pm +++ b/lib/Sietima/Role/WithOwner.pm @@ -4,7 +4,7 @@ use Sietima::Policy; use Sietima::Types qw(Address AddressFromStr); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: role for lists with an owner @@ -37,7 +37,7 @@ Sietima::Role::WithOwner - role for lists with an owner =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -74,7 +74,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Role/WithPostAddress.pm b/lib/Sietima/Role/WithPostAddress.pm index 0e22e52..e52b59e 100644 --- a/lib/Sietima/Role/WithPostAddress.pm +++ b/lib/Sietima/Role/WithPostAddress.pm @@ -4,7 +4,7 @@ use Sietima::Policy; use Sietima::Types qw(Address AddressFromStr); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: role for lists with a posting address @@ -36,7 +36,7 @@ Sietima::Role::WithPostAddress - role for lists with a posting address =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 SYNOPSIS @@ -69,7 +69,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Runner.pm b/lib/Sietima/Runner.pm index 58e73ef..be79e34 100644 --- a/lib/Sietima/Runner.pm +++ b/lib/Sietima/Runner.pm @@ -3,7 +3,7 @@ use Moo; use Sietima::Policy; use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: C<App::Spec::Run> for Sietima @@ -32,7 +32,7 @@ Sietima::Runner - C<App::Spec::Run> for Sietima =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 DESCRIPTION @@ -52,7 +52,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Subscriber.pm b/lib/Sietima/Subscriber.pm index b888efb..cbaf4c2 100644 --- a/lib/Sietima/Subscriber.pm +++ b/lib/Sietima/Subscriber.pm @@ -2,13 +2,13 @@ package Sietima::Subscriber; use Moo; use Sietima::Policy; use Types::Standard qw(ArrayRef HashRef Object); -use Type::Params qw(compile); +use Type::Params -sigs; use Sietima::Types qw(Address AddressFromStr); use Email::Address; use List::AllUtils qw(any); use namespace::clean; -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: a subscriber to a mailing list @@ -41,12 +41,11 @@ has prefs => ( ); -sub match { - # we can't use the sub signature here, because we need the - # coercion - state $check = compile(Object,Address->plus_coercions(AddressFromStr)); - my ($self,$addr) = $check->(@_); - +signature_for match => ( + method => Object, + positional => [ Address->plus_coercions(AddressFromStr) ], +); +sub match($self,$addr) { return any { $addr->address eq $_->address } $self->primary, $self->aliases->@*; } @@ -66,7 +65,7 @@ Sietima::Subscriber - a subscriber to a mailing list =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 DESCRIPTION @@ -127,7 +126,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. diff --git a/lib/Sietima/Types.pm b/lib/Sietima/Types.pm index b5e8398..7b98e39 100644 --- a/lib/Sietima/Types.pm +++ b/lib/Sietima/Types.pm @@ -13,7 +13,7 @@ use Type::Library Subscriber SubscriberFromAddress SubscriberFromStr SubscriberFromHashRef Transport MailStore MailStoreFromHashRef); -our $VERSION = '1.0.5'; # VERSION +our $VERSION = '1.1.3'; # VERSION # ABSTRACT: type library for Sietima @@ -85,7 +85,7 @@ Sietima::Types - type library for Sietima =head1 VERSION -version 1.0.5 +version 1.1.3 =head1 DESCRIPTION @@ -194,7 +194,7 @@ Gianni Ceccarelli <dakkar@thenautilus.net> =head1 COPYRIGHT AND LICENSE -This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>. +This software is copyright (c) 2025 by Gianni Ceccarelli <dakkar@thenautilus.net>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. |