diff options
Diffstat (limited to 'perllib')
| -rw-r--r-- | perllib/Email/Sender/Transport/SMTP.pm | 380 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App.pm | 11 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Model/EmailSend.pm | 19 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Email.pm | 4 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Email/Sender.pm | 50 | ||||
| -rw-r--r-- | perllib/FixMyStreet/EmailSend.pm | 78 | ||||
| -rw-r--r-- | perllib/FixMyStreet/EmailSend/Variable.pm | 17 | ||||
| -rw-r--r-- | perllib/FixMyStreet/TestMech.pm | 9 |
8 files changed, 446 insertions, 122 deletions
diff --git a/perllib/Email/Sender/Transport/SMTP.pm b/perllib/Email/Sender/Transport/SMTP.pm new file mode 100644 index 000000000..c4eb6890c --- /dev/null +++ b/perllib/Email/Sender/Transport/SMTP.pm @@ -0,0 +1,380 @@ +package Email::Sender::Transport::SMTP; +# ABSTRACT: send email over SMTP +$Email::Sender::Transport::SMTP::VERSION = '1.300030'; +use Moo; + +use Email::Sender::Failure::Multi; +use Email::Sender::Success::Partial; +use Email::Sender::Role::HasMessage (); +use Email::Sender::Util; +use MooX::Types::MooseLike::Base qw(Bool Int Str HashRef); +use Net::SMTP 3.07; # SSL support, fixed datasend + +use utf8 (); # See below. -- rjbs, 2015-05-14 +use version (); + +#pod =head1 DESCRIPTION +#pod +#pod This transport is used to send email over SMTP, either with or without secure +#pod sockets (SSL/TLS). It is one of the most complex transports available, capable +#pod of partial success. +#pod +#pod For a potentially more efficient version of this transport, see +#pod L<Email::Sender::Transport::SMTP::Persistent>. +#pod +#pod =head1 ATTRIBUTES +#pod +#pod The following attributes may be passed to the constructor: +#pod +#pod =over 4 +#pod +#pod =item C<host>: the name of the host to connect to; defaults to C<localhost> +#pod +#pod =item C<ssl>: if 'starttls', use STARTTLS; if 'ssl' (or 1), connect securely; +#pod otherwise, no security +#pod +#pod =item C<ssl_options>: passed to Net::SMTP constructor for 'ssl' connections or +#pod to starttls for 'starttls' connections; should contain extra options for +#pod IO::Socket::SSL +#pod +#pod =item C<port>: port to connect to; defaults to 25 for non-SSL, 465 for 'ssl', +#pod 587 for 'starttls' +#pod +#pod =item C<timeout>: maximum time in secs to wait for server; default is 120 +#pod +#pod =cut + +sub BUILD { + my ($self) = @_; + Carp::croak("do not pass port number to SMTP transport in host, use port parameter") + if $self->host =~ /:/; +} + +has host => (is => 'ro', isa => Str, default => sub { 'localhost' }); +has ssl => (is => 'ro', isa => Str, default => sub { 0 }); + +has _security => ( + is => 'ro', + lazy => 1, + init_arg => undef, + default => sub { + my $ssl = $_[0]->ssl; + return '' unless $ssl; + $ssl = lc $ssl; + return 'starttls' if 'starttls' eq $ssl; + return 'ssl' if $ssl eq 1 or $ssl eq 'ssl'; + + Carp::cluck(qq{true "ssl" argument to Email::Sender::Transport::SMTP should be 'ssl' or 'startls' or '1' but got '$ssl'}); + + return 1; + }, +); + +has ssl_options => (is => 'ro', isa => HashRef, default => sub { {} }); + +has port => ( + is => 'ro', + isa => Int, + lazy => 1, + default => sub { + return $_[0]->_security eq 'starttls' ? 587 + : $_[0]->_security eq 'ssl' ? 465 + : 25 + }, +); + +has timeout => (is => 'ro', isa => Int, default => sub { 120 }); + +#pod =item C<sasl_username>: the username to use for auth; optional +#pod +#pod =item C<sasl_password>: the password to use for auth; required if C<username> is provided +#pod +#pod =item C<allow_partial_success>: if true, will send data even if some recipients were rejected; defaults to false +#pod +#pod =cut + +has sasl_username => (is => 'ro', isa => Str); +has sasl_password => (is => 'ro', isa => Str); + +has allow_partial_success => (is => 'ro', isa => Bool, default => sub { 0 }); + +#pod =item C<helo>: what to say when saying HELO; no default +#pod +#pod =item C<localaddr>: local address from which to connect +#pod +#pod =item C<localport>: local port from which to connect +#pod +#pod =cut + +has helo => (is => 'ro', isa => Str); +has localaddr => (is => 'ro'); +has localport => (is => 'ro', isa => Int); + +#pod =item C<debug>: if true, put the L<Net::SMTP> object in debug mode +#pod +#pod =back +#pod +#pod =cut + +has debug => (is => 'ro', isa => Bool, default => sub { 0 }); + +# I am basically -sure- that this is wrong, but sending hundreds of millions of +# messages has shown that it is right enough. I will try to make it textbook +# later. -- rjbs, 2008-12-05 +sub _quoteaddr { + my $addr = shift; + my @localparts = split /\@/, $addr; + my $domain = pop @localparts; + my $localpart = join q{@}, @localparts; + + return $addr # The first regex here is RFC 821 "specials" excepting dot. + unless $localpart =~ /[\x00-\x1F\x7F<>\(\)\[\]\\,;:@"]/ + or $localpart =~ /^\./ + or $localpart =~ /\.$/; + return join q{@}, qq("$localpart"), $domain; +} + +sub _smtp_client { + my ($self) = @_; + + my $class = "Net::SMTP"; + + my $smtp = $class->new( $self->_net_smtp_args ); + + unless ($smtp) { + $self->_throw( + sprintf "unable to establish SMTP connection to %s port %s", + $self->host, + $self->port, + ); + } + + if ($self->_security eq 'starttls') { + $self->_throw("can't STARTTLS: " . $smtp->message) + unless $smtp->starttls(%{ $self->ssl_options }); + } + + if ($self->sasl_username) { + $self->_throw("sasl_username but no sasl_password") + unless defined $self->sasl_password; + + unless ($smtp->auth($self->sasl_username, $self->sasl_password)) { + if ($smtp->message =~ /MIME::Base64|Authen::SASL/) { + Carp::confess("SMTP auth requires MIME::Base64 and Authen::SASL"); + } + + $self->_throw('failed AUTH', $smtp); + } + } + + return $smtp; +} + +sub _net_smtp_args { + my ($self) = @_; + + return ( + $self->host, + Port => $self->port, + Timeout => $self->timeout, + Debug => $self->debug, + + (($self->_security eq 'ssl') + ? (SSL => 1, %{ $self->ssl_options }) + : ()), + + defined $self->helo ? (Hello => $self->helo) : (), + defined $self->localaddr ? (LocalAddr => $self->localaddr) : (), + defined $self->localport ? (LocalPort => $self->localport) : (), + ); +} + +sub _throw { + my ($self, @rest) = @_; + Email::Sender::Util->_failure(@rest)->throw; +} + +sub send_email { + my ($self, $email, $env) = @_; + + Email::Sender::Failure->throw("no valid addresses in recipient list") + unless my @to = grep { defined and length } @{ $env->{to} }; + + my $smtp = $self->_smtp_client; + + my $FAULT = sub { $self->_throw($_[0], $smtp); }; + + $smtp->mail(_quoteaddr($env->{from})) + or $FAULT->("$env->{from} failed after MAIL FROM"); + + my @failures; + my @ok_rcpts; + + for my $addr (@to) { + if ($smtp->to(_quoteaddr($addr))) { + push @ok_rcpts, $addr; + } else { + # my ($self, $error, $smtp, $error_class, @rest) = @_; + push @failures, Email::Sender::Util->_failure( + undef, + $smtp, + recipients => [ $addr ], + ); + } + } + + # This logic used to include: or (@ok_rcpts == 1 and $ok_rcpts[0] eq '0') + # because if called without SkipBad, $smtp->to can return 1 or 0. This + # should not happen because we now always pass SkipBad and do the counting + # ourselves. Still, I've put this comment here (a) in memory of the + # suffering it caused to have to find that problem and (b) in case the + # original problem is more insidious than I thought! -- rjbs, 2008-12-05 + + if ( + @failures + and ((@ok_rcpts == 0) or (! $self->allow_partial_success)) + ) { + $failures[0]->throw if @failures == 1; + + my $message = sprintf '%s recipients were rejected during RCPT', + @ok_rcpts ? 'some' : 'all'; + + Email::Sender::Failure::Multi->throw( + message => $message, + failures => \@failures, + ); + } + + # restore Pobox's support for streaming, code-based messages, and arrays here + # -- rjbs, 2008-12-04 + + $smtp->data or $FAULT->("error at DATA start"); + + my $msg_string = $email->as_string; + my $hunk_size = $self->_hunk_size; + + while (length $msg_string) { + my $next_hunk = substr $msg_string, 0, $hunk_size, ''; + $smtp->datasend($next_hunk) or $FAULT->("error at during DATA"); + } + + $smtp->dataend or $FAULT->("error at after DATA"); + + my $message = $smtp->message; + + $self->_message_complete($smtp); + + # We must report partial success (failures) if applicable. + return $self->success({ message => $message }) unless @failures; + return $self->partial_success({ + message => $message, + failure => Email::Sender::Failure::Multi->new({ + message => 'some recipients were rejected during RCPT', + failures => \@failures + }), + }); +} + +sub _hunk_size { 2**20 } # send messages to DATA in hunks of 1 mebibyte + +sub success { + my $self = shift; + my $success = Moo::Role->create_class_with_roles('Email::Sender::Success', 'Email::Sender::Role::HasMessage')->new(@_); +} + +sub partial_success { + my $self = shift; + my $partial_success = Moo::Role->create_class_with_roles('Email::Sender::Success::Partial', 'Email::Sender::Role::HasMessage')->new(@_); +} + +sub _message_complete { $_[1]->quit; } + +#pod =head1 PARTIAL SUCCESS +#pod +#pod If C<allow_partial_success> was set when creating the transport, the transport +#pod may return L<Email::Sender::Success::Partial> objects. Consult that module's +#pod documentation. +#pod +#pod =cut + +with 'Email::Sender::Transport'; +no Moo; +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Email::Sender::Transport::SMTP - send email over SMTP + +=head1 VERSION + +version 1.300030 + +=head1 DESCRIPTION + +This transport is used to send email over SMTP, either with or without secure +sockets (SSL/TLS). It is one of the most complex transports available, capable +of partial success. + +For a potentially more efficient version of this transport, see +L<Email::Sender::Transport::SMTP::Persistent>. + +=head1 ATTRIBUTES + +The following attributes may be passed to the constructor: + +=over 4 + +=item C<host>: the name of the host to connect to; defaults to C<localhost> + +=item C<ssl>: if 'starttls', use STARTTLS; if 'ssl' (or 1), connect securely; +otherwise, no security + +=item C<ssl_options>: passed to Net::SMTP constructor for 'ssl' connections or +to starttls for 'starttls' connections; should contain extra options for +IO::Socket::SSL + +=item C<port>: port to connect to; defaults to 25 for non-SSL, 465 for 'ssl', +587 for 'starttls' + +=item C<timeout>: maximum time in secs to wait for server; default is 120 + +=item C<sasl_username>: the username to use for auth; optional + +=item C<sasl_password>: the password to use for auth; required if C<username> is provided + +=item C<allow_partial_success>: if true, will send data even if some recipients were rejected; defaults to false + +=item C<helo>: what to say when saying HELO; no default + +=item C<localaddr>: local address from which to connect + +=item C<localport>: local port from which to connect + +=item C<debug>: if true, put the L<Net::SMTP> object in debug mode + +=back + +=head1 PARTIAL SUCCESS + +If C<allow_partial_success> was set when creating the transport, the transport +may return L<Email::Sender::Success::Partial> objects. Consult that module's +documentation. + +=head1 AUTHOR + +Ricardo Signes <rjbs@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2016 by Ricardo Signes. + +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/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm index 9660d327a..35e8c2537 100644 --- a/perllib/FixMyStreet/App.pm +++ b/perllib/FixMyStreet/App.pm @@ -9,9 +9,11 @@ use FixMyStreet::Cobrand; use Memcached; use FixMyStreet::Map; use FixMyStreet::Email; +use FixMyStreet::Email::Sender; use Utils; use Path::Tiny 'path'; +use Try::Tiny; use URI; use URI::QueryParam; @@ -346,8 +348,13 @@ sub send_email { $data->{_html_images_} = \@inline_images if @inline_images; my $email = mySociety::Locale::in_gb_locale { FixMyStreet::Email::construct_email($data) }; - my $return = $c->model('EmailSend')->send($email); - $c->log->error("$return") if !$return; + + try { + FixMyStreet::Email::Sender->send($email, { from => $sender }); + } catch { + my $error = $_ || 'unknown error'; + $c->log->error("$error"); + }; return $email; } diff --git a/perllib/FixMyStreet/App/Model/EmailSend.pm b/perllib/FixMyStreet/App/Model/EmailSend.pm deleted file mode 100644 index 93751d4a6..000000000 --- a/perllib/FixMyStreet/App/Model/EmailSend.pm +++ /dev/null @@ -1,19 +0,0 @@ -package FixMyStreet::App::Model::EmailSend; -use base 'Catalyst::Model::Factory'; - -use strict; -use warnings; - -=head1 NAME - -FixMyStreet::App::Model::EmailSend - -=head1 DESCRIPTION - -Catalyst Model wrapper around FixMyStreet::EmailSend - -=cut - -__PACKAGE__->config( - class => 'FixMyStreet::EmailSend', -); diff --git a/perllib/FixMyStreet/Email.pm b/perllib/FixMyStreet/Email.pm index e0d82a8ef..ea84e3966 100644 --- a/perllib/FixMyStreet/Email.pm +++ b/perllib/FixMyStreet/Email.pm @@ -17,7 +17,7 @@ use mySociety::Random qw(random_bytes); use Utils::Email; use FixMyStreet; use FixMyStreet::DB; -use FixMyStreet::EmailSend; +use FixMyStreet::Email::Sender; sub test_dmarc { my $email = shift; @@ -187,7 +187,7 @@ sub send_cron { print $email->as_string; return 1; # Failure } else { - my $result = FixMyStreet::EmailSend->new({ env_from => $env_from })->send($email); + my $result = FixMyStreet::Email::Sender->try_to_send($email, { from => $env_from }); return $result ? 0 : 1; } } diff --git a/perllib/FixMyStreet/Email/Sender.pm b/perllib/FixMyStreet/Email/Sender.pm new file mode 100644 index 000000000..e6148a56c --- /dev/null +++ b/perllib/FixMyStreet/Email/Sender.pm @@ -0,0 +1,50 @@ +package FixMyStreet::Email::Sender; + +use parent Email::Sender::Simple; +use strict; +use warnings; + +use Email::Sender::Util; +use FixMyStreet; + +=head1 NAME + +FixMyStreet::Email::Sender + +=head1 DESCRIPTION + +Subclass of Email::Sender - configuring it correctly according to our config. + +If the config value 'SMTP_SMARTHOST' is set then email is routed via SMTP to +that. Otherwise it is sent using a 'sendmail' like binary on the local system. + +And finally if if FixMyStreet->test_mode returns true then emails are not sent +at all but are stored in memory for the test suite to inspect (using +Email::Send::Test). + +=cut + +sub build_default_transport { + if ( FixMyStreet->test_mode ) { + Email::Sender::Util->easy_transport(Test => {}); + } elsif ( my $smtp_host = FixMyStreet->config('SMTP_SMARTHOST') ) { + my $type = FixMyStreet->config('SMTP_TYPE') || ''; + my $port = FixMyStreet->config('SMTP_PORT') || ''; + my $username = FixMyStreet->config('SMTP_USERNAME') || ''; + my $password = FixMyStreet->config('SMTP_PASSWORD') || ''; + + my $ssl = $type eq 'tls' ? 'starttls' : $type eq 'ssl' ? 'ssl' : ''; + my $args = { + host => $smtp_host, + ssl => $ssl, + sasl_username => $username, + sasl_password => $password, + }; + $args->{port} = $port if $port; + Email::Sender::Util->easy_transport(SMTP => $args); + } else { + Email::Sender::Util->easy_transport(Sendmail => {}); + } +} + +1; diff --git a/perllib/FixMyStreet/EmailSend.pm b/perllib/FixMyStreet/EmailSend.pm deleted file mode 100644 index 09f434931..000000000 --- a/perllib/FixMyStreet/EmailSend.pm +++ /dev/null @@ -1,78 +0,0 @@ -package FixMyStreet::EmailSend; - -use strict; -use warnings; - -BEGIN { - # Should move away from Email::Send, but until then: - $Return::Value::NO_CLUCK = 1; -} - -use FixMyStreet; -use Email::Send; - -=head1 NAME - -FixMyStreet::EmailSend - -=head1 DESCRIPTION - -Thin wrapper around Email::Send - configuring it correctly according to our config. - -If the config value 'SMTP_SMARTHOST' is set then email is routed via SMTP to -that. Otherwise it is sent using a 'sendmail' like binary on the local system. - -And finally if if FixMyStreet->test_mode returns true then emails are not sent -at all but are stored in memory for the test suite to inspect (using -Email::Send::Test). - -=cut - -my $args = undef; - -if ( FixMyStreet->test_mode ) { - # Email::Send::Test - $args = { mailer => 'Test', }; -} elsif ( my $smtp_host = FixMyStreet->config('SMTP_SMARTHOST') ) { - # Email::Send::SMTP - my $type = FixMyStreet->config('SMTP_TYPE') || ''; - my $port = FixMyStreet->config('SMTP_PORT') || ''; - my $username = FixMyStreet->config('SMTP_USERNAME') || ''; - my $password = FixMyStreet->config('SMTP_PASSWORD') || ''; - - unless ($port) { - $port = 25; - $port = 465 if $type eq 'ssl'; - $port = 587 if $type eq 'tls'; - } - - my $mailer_args = [ - Host => $smtp_host, - Port => $port, - ]; - push @$mailer_args, ssl => 1 if $type eq 'ssl'; - push @$mailer_args, tls => 1 if $type eq 'tls'; - push @$mailer_args, username => $username, password => $password - if $username && $password; - $args = { - mailer => 'FixMyStreet::EmailSend::Variable', - mailer_args => $mailer_args, - }; -} else { - # Email::Send::Sendmail - $args = { mailer => 'Sendmail' }; -} - -sub new { - my ($cls, $hash) = @_; - $hash ||= {}; - my %args = ( %$args, %$hash ); - - my $sender = delete($args{env_from}); - if ($sender) { - $args{mailer_args} = [ @{$args{mailer_args}} ] if $args{mailer_args}; - push @{$args{mailer_args}}, env_from => $sender; - } - - return Email::Send->new(\%args); -} diff --git a/perllib/FixMyStreet/EmailSend/Variable.pm b/perllib/FixMyStreet/EmailSend/Variable.pm deleted file mode 100644 index 4ba56dd41..000000000 --- a/perllib/FixMyStreet/EmailSend/Variable.pm +++ /dev/null @@ -1,17 +0,0 @@ -package FixMyStreet::EmailSend::Variable; -use base Email::Send::SMTP; -use FixMyStreet; - -my $sender; - -sub send { - my ($class, $message, %args) = @_; - $sender = delete($args{env_from}) || FixMyStreet->config('DO_NOT_REPLY_EMAIL'); - $class->SUPER::send($message, %args); -} - -sub get_env_sender { - $sender; -} - -1; diff --git a/perllib/FixMyStreet/TestMech.pm b/perllib/FixMyStreet/TestMech.pm index 122a5d0c9..c22789fb0 100644 --- a/perllib/FixMyStreet/TestMech.pm +++ b/perllib/FixMyStreet/TestMech.pm @@ -13,7 +13,7 @@ use Test::WWW::Mechanize::Catalyst 'FixMyStreet::App'; use Test::More; use Web::Scraper; use Carp; -use Email::Send::Test; +use FixMyStreet::Email::Sender; use JSON::MaybeXS; =head1 NAME @@ -182,7 +182,7 @@ Clear the email queue. sub clear_emails_ok { my $mech = shift; - Email::Send::Test->clear; + FixMyStreet::Email::Sender->default_transport->clear_deliveries; $mech->builder->ok( 1, 'cleared email queue' ); return 1; } @@ -199,7 +199,7 @@ sub email_count_is { my $mech = shift; my $number = shift || 0; - $mech->builder->is_num( scalar( Email::Send::Test->emails ), + $mech->builder->is_num( scalar( FixMyStreet::Email::Sender->default_transport->delivery_count ), $number, "checking for $number email(s) in the queue" ); } @@ -215,7 +215,8 @@ In list context returns all the emails (or none). sub get_email { my $mech = shift; - my @emails = Email::Send::Test->emails; + my @emails = FixMyStreet::Email::Sender->default_transport->deliveries; + @emails = map { $_->{email}->object } @emails; return @emails if wantarray; |