Koha/Email.pm

   1 package Koha::Email;
   2
   3 # Copyright 2014 Catalyst
   4 #           2020 Theke Solutions
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 use Modern::Perl;
  22
  23 use Email::Address;
  24 use Email::MessageID;
  25 use Email::MIME;
  26 use List::Util qw( pairs );
  27 use Scalar::Util qw( blessed );
  28
  29 use Koha::Exceptions;
  30
  31 use C4::Context;
  32
  33 use base qw( Email::Stuffer );
  34
  35 =head1 NAME
  36
  37 Koha::Email - A wrapper around Email::Stuffer
  38
  39 =head1 API
  40
  41 =head2 Class methods
  42
  43 =head3 new_from_string
  44
  45     my $email = Koha::Email->new_from_string( $email_string );
  46
  47 Constructor for the Koha::Email class. The I<$email_string> (mandatory)
  48 parameter will be parsed with I<Email::MIME>.
  49
  50 Note: I<$email_string> can be the produced by the I<as_string> method from
  51 B<Koha::Email> or B<Email::MIME>.
  52
  53 =cut
  54
  55 sub new_from_string {
  56     my ( $class, $email_string ) = @_;
  57
  58     Koha::Exceptions::MissingParameter->throw("Mandatory string parameter missing.")
  59         unless $email_string;
  60
  61     my $self = $class->SUPER::new();
  62     my $mime = Email::MIME->new( $email_string );
  63     $self->{email} = $mime;
  64
  65     return $self;
  66 }
  67
  68 =head3 create
  69
  70     my $email = Koha::Email->create(
  71         {
  72           [ text_body   => $text_message,
  73             html_body   => $html_message,
  74             body_params => $body_params ]
  75             from        => $from,
  76             to          => $to,
  77             cc          => $cc,
  78             bcc         => $bcc,
  79             reply_to    => $reply_to,
  80             sender      => $sender,
  81             subject     => $subject,
  82         }
  83     );
  84
  85 This method creates a new Email::Stuffer object taking Koha specific configurations
  86 into account.
  87
  88 The encoding defaults to utf-8. It can be set as part of the body_params hashref. See
  89 I<Email::Stuffer> and I<Email::MIME> for more details on the available options.
  90
  91 Parameters:
  92  - I<from> defaults to the value of the I<KohaAdminEmailAddress> system preference
  93  - The I<SendAllEmailsTo> system preference overloads the I<to>, I<cc> and I<bcc> parameters
  94  - I<reply_to> defaults to the value of the I<ReplytoDefault> system preference
  95  - I<sender> defaults to the value of the I<ReturnpathDefault> system preference
  96
  97 Both I<text_body> and I<html_body> can be set later. I<body_params> will be passed if present
  98 to the constructor.
  99
 100 =cut
 101
 102 sub create {
 103     my ( $self, $params ) = @_;
 104
 105     my $args = {};
 106     $args->{from} = $params->{from} || C4::Context->preference('KohaAdminEmailAddress');
 107     Koha::Exceptions::BadParameter->throw(
 108         error     => "Invalid 'from' parameter: " . $args->{from},
 109         parameter => 'from'
 110     ) unless Koha::Email->is_valid( $args->{from} );    # from is mandatory
 111
 112     $args->{subject} = $params->{subject} // '';
 113
 114     if ( C4::Context->preference('SendAllEmailsTo') ) {
 115         $args->{to} = C4::Context->preference('SendAllEmailsTo');
 116     }
 117     else {
 118         $args->{to} = $params->{to};
 119     }
 120
 121     my @emails = split(',', $args->{to});
 122     foreach my $email (@emails) {
 123        $email =~ s/ //g;
 124        Koha::Exceptions::BadParameter->throw(
 125            error     => "Invalid 'to' parameter: ".$email,
 126            parameter => 'to'
 127        ) unless Koha::Email->is_valid($email);
 128     }
 129
 130     my $addresses = {};
 131     $addresses->{reply_to} = $params->{reply_to};
 132     $addresses->{reply_to} ||= C4::Context->preference('ReplytoDefault')
 133         if C4::Context->preference('ReplytoDefault');
 134
 135     $addresses->{sender} = $params->{sender};
 136     $addresses->{sender} ||= C4::Context->preference('ReturnpathDefault')
 137         if C4::Context->preference('ReturnpathDefault');
 138
 139     unless ( C4::Context->preference('SendAllEmailsTo') ) {
 140         $addresses->{cc} = $params->{cc}
 141             if exists $params->{cc};
 142         $addresses->{bcc} = $params->{bcc}
 143             if exists $params->{bcc};
 144     }
 145
 146     foreach my $address ( keys %{$addresses} ) {
 147         Koha::Exceptions::BadParameter->throw(
 148             error => "Invalid '$address' parameter: " . $addresses->{$address},
 149             parameter => $address
 150           )
 151           if $addresses->{$address}
 152           and !Koha::Email->is_valid( $addresses->{$address} );
 153     }
 154
 155     $args->{cc} = $addresses->{cc}
 156         if $addresses->{cc};
 157     $args->{bcc} = $addresses->{bcc}
 158         if $addresses->{bcc};
 159
 160     my $email;
 161     # FIXME: This is ugly, but aids backportability
 162     # TODO: Remove this and move address and default headers handling
 163     #       to separate subs to be (re)used
 164     if ( blessed($self) ) {
 165         $email = $self;
 166         $email->to( $args->{to} )             if $args->{to};
 167         $email->from( $args->{from} )         if $args->{from};
 168         $email->cc( $args->{cc} )             if $args->{cc};
 169         $email->bcc( $args->{bcc} )           if $args->{bcc};
 170         $email->reply_to( $args->{reply_to} ) if $args->{reply_to};
 171         $email->subject( $args->{subject} )   if $args->{subject};
 172     }
 173     else {
 174         $email = $self->SUPER::new( $args );
 175     }
 176
 177     $email->header( 'Reply-To', $addresses->{reply_to} )
 178         if $addresses->{reply_to};
 179
 180     $email->header( 'Sender'       => $addresses->{sender} ) if $addresses->{sender};
 181     $email->header( 'Content-Type' => $params->{contenttype} ) if $params->{contenttype};
 182     $email->header( 'X-Mailer'     => "Koha" );
 183     $email->header( 'Message-ID'   => Email::MessageID->new->in_brackets );
 184
 185     if ( $params->{text_body} ) {
 186         $email->text_body( $params->{text_body}, %{ $params->{body_params} } );
 187     }
 188     elsif ( $params->{html_body} ) {
 189         $email->html_body( $params->{html_body}, %{ $params->{body_params} } );
 190     }
 191
 192     return $email;
 193 }
 194
 195 =head3 send_or_die
 196
 197     $email->send_or_die({ transport => $transport [, $args] });
 198
 199 Overloaded Email::Stuffer I<send_or_die> method, that takes care of Bcc and Return-path
 200 handling.
 201
 202 Bcc is removed from the message headers, and included in the recipients list to be
 203 passed to I<send_or_die>.
 204
 205 Return-path, 'MAIL FROM', is set to the 'Sender' email header unless an explicit 'from'
 206 parameter is passed to send_or_die.  'Return-path' headers are actually set by the MTA,
 207 usually using the 'MAIL FROM' information set at mail server connection time.
 208
 209 =cut
 210
 211 sub send_or_die {
 212     my ( $self, $args ) = @_;
 213
 214     unless ( $args->{to} ) {    # don't do it if passed an explicit 'to' param
 215
 216         my @recipients;
 217
 218         my @headers = $self->email->header_str_pairs;
 219         foreach my $pair ( pairs @headers ) {
 220             my ( $header, $value ) = @$pair;
 221             push @recipients, split (', ', $value)
 222                 if grep { $_ eq $header } ('To', 'Cc', 'Bcc');
 223         }
 224
 225         # Remove the Bcc header
 226         $self->email->header_str_set('Bcc');
 227
 228         # Tweak $args
 229         $args->{to} = \@recipients;
 230     }
 231
 232     unless ( $args->{from} ) {    # don't do it if passed an explicit 'from' param
 233         $args->{from} = $self->email->header_str('Sender');
 234         $self->email->header_str_set('Sender'); # remove Sender header
 235     }
 236
 237     $self->SUPER::send_or_die($args);
 238 }
 239
 240 =head3 is_valid
 241
 242     my $is_valid = Koha::Email->is_valid($email_address);
 243
 244 Return true is the email address passed in parameter is valid following RFC 2822.
 245
 246 =cut
 247
 248 sub is_valid {
 249     my ( $class, $email ) = @_;
 250     my @addrs = Email::Address->parse($email);
 251     return @addrs ? 1 : 0;
 252 }
 253
 254 1;