Refactor email handling to use Email::MIME alone.

4 files changed, 161 insertions, 69 deletions

diff --git a/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm
index b8ce2e051..af9dc1f9d 100644
--- a/perllib/FixMyStreet/App.pm
+++ b/perllib/FixMyStreet/App.pm
@@ -6,7 +6,6 @@ use Catalyst::Runtime 5.80;
 use FixMyStreet;
 use FixMyStreet::Cobrand;
 use Memcached;
-use mySociety::Email;
 use mySociety::Random qw(random_bytes);
 use FixMyStreet::Map;
 use FixMyStreet::Email;
@@ -319,37 +318,23 @@ sub send_email {
 
     return if FixMyStreet::Email::is_abuser($c->model('DB')->schema, $vars->{to});
 
-    # render the template
-    my $content = $c->view('Email')->render( $c, $template, $vars );
-
-    # create an email - will parse headers out of content
-    my $email = Email::Simple->new($content);
-    $email->header_set( 'Subject', $vars->{subject} ) if $vars->{subject};
-    $email->header_set( 'Reply-To', $vars->{'Reply-To'} ) if $vars->{'Reply-To'};
-
-    $email->header_set( 'Message-ID', sprintf('<fms-%s-%s@%s>',
-        time(), unpack('h*', random_bytes(5, 1)), $c->config->{EMAIL_DOMAIN}
-    ) );
-
-    # pass the email into mySociety::Email to construct the on the wire 7bit
-    # format - this should probably happen in the transport instead but hohum.
-    my $email_text = mySociety::Locale::in_gb_locale { mySociety::Email::construct_email(
+    my $email = mySociety::Locale::in_gb_locale { FixMyStreet::Email::construct_email(
         {
-            _template_ => $email->body,    # will get line wrapped
+            _template_ => $c->view('Email')->render( $c, $template, $vars ),
             _parameters_ => {},
-            _line_indent => '',
+            _attachments_ => $extra_stash_values->{attachments},
             From => $vars->{from},
             To => $vars->{to},
-            $email->header_pairs
+            'Message-ID' => sprintf('<fms-%s-%s@%s>',
+                time(), unpack('h*', random_bytes(5, 1)), $c->config->{EMAIL_DOMAIN}
+            ),
+            $vars->{subject} ? (Subject => $vars->{subject}) : (),
+            $vars->{'Reply-To'} ? ('Reply-To' => $vars->{'Reply-To'}) : (),
         }
     ) };
 
-    if (my $attachments = $extra_stash_values->{attachments}) {
-        $email_text = FixMyStreet::Email::munge_attachments($email_text, $attachments);
-    }
-
     # send the email
-    $c->model('EmailSend')->send($email_text);
+    $c->model('EmailSend')->send($email);
 
     return $email;
 }
diff --git a/perllib/FixMyStreet/App/Controller/Contact.pm b/perllib/FixMyStreet/App/Controller/Contact.pm
index 115f4e3d2..e20011471 100644
--- a/perllib/FixMyStreet/App/Controller/Contact.pm
+++ b/perllib/FixMyStreet/App/Controller/Contact.pm
@@ -242,8 +242,7 @@ sub send_email : Private {
 
     my $from = [ $c->stash->{em}, $c->stash->{form_name} ];
     my $params = {
-        to      => [ [ $recipient, _($recipient_name) ] ],
-        subject => 'FMS message: ' . $c->stash->{subject},
+        to => [ [ $recipient, _($recipient_name) ] ],
     };
     if (FixMyStreet::Email::test_dmarc($c->stash->{em})) {
         $params->{'Reply-To'} = [ $from ];
diff --git a/perllib/FixMyStreet/Cobrand/Zurich.pm b/perllib/FixMyStreet/Cobrand/Zurich.pm
index c7e3c4d45..596ef2dc6 100644
--- a/perllib/FixMyStreet/Cobrand/Zurich.pm
+++ b/perllib/FixMyStreet/Cobrand/Zurich.pm
@@ -1029,7 +1029,7 @@ sub munge_sendreport_params {
                 },
             }
         } (0..$num-1);
-        $params->{attachments} = \@attachments;
+        $params->{_attachments_} = \@attachments;
     }
 }
 
diff --git a/perllib/FixMyStreet/Email.pm b/perllib/FixMyStreet/Email.pm
index 1787c32da..49f4632a8 100644
--- a/perllib/FixMyStreet/Email.pm
+++ b/perllib/FixMyStreet/Email.pm
@@ -1,6 +1,8 @@
 package FixMyStreet::Email;
 
+use Email::MIME;
 use Encode;
+use POSIX qw();
 use Template;
 use Digest::HMAC_SHA1 qw(hmac_sha1_hex);
 use mySociety::Email;
@@ -105,15 +107,10 @@ sub send_cron {
     $site_name = Utils::trim_text(Encode::decode('utf8', $site_name));
     $params->{_parameters_}->{site_name} = $site_name;
 
-    $params->{_line_indent} = '';
-    my $attachments = delete $params->{attachments};
-
-    my $email = mySociety::Locale::in_gb_locale { mySociety::Email::construct_email($params) };
-
-    $email = munge_attachments($email, $attachments) if $attachments;
+    my $email = mySociety::Locale::in_gb_locale { construct_email($params) };
 
     if ($nomail) {
-        print $email;
+        print $email->as_string;
         return 1; # Failure
     } else {
         my $result = FixMyStreet::EmailSend->new({ env_from => $env_from })->send($email);
@@ -121,41 +118,152 @@ sub send_cron {
     }
 }
 
-sub munge_attachments {
-    my ($message, $attachments) = @_;
-    # $attachments should be an array_ref of things that can be parsed to Email::MIME,
-    # for example
-    #    [
-    #      body => $binary_data,
-    #      attributes => {
-    #          content_type => 'image/jpeg',
-    #          encoding => 'base64',
-    #          filename => '1234.1.jpeg',
-    #          name     => '1234.1.jpeg',
-    #      },
-    #      ...
-    #    ]
-    #
-    # XXX: mySociety::Email::construct_email isn't using a MIME library and
-    # requires more analysis to refactor, so for now, we'll simply parse the
-    # generated MIME and add attachments.
-    #
-    # (Yes, this means that the email is constructed by Email::Simple, munged
-    # manually by custom code, turned back into Email::Simple, and then munged
-    # with Email::MIME.  What's your point?)
-
-    require Email::MIME;
-    my $mime = Email::MIME->new($message);
-    $mime->parts_add([ map { Email::MIME->create(%$_)} @$attachments ]);
-    my $data = $mime->as_string;
-
-    # unsure why Email::MIME adds \r\n. Possibly mail client should handle
-    # gracefully, BUT perhaps as the segment constructed by
-    # mySociety::Email::construct_email strips to \n, they seem not to.
-    # So we re-run the same regexp here to the added part.
-    $data =~ s/\r\n/\n/gs;
-
-    return $data;
+=item construct_email SPEC
+
+Construct an email message according to SPEC, which is an associative array
+containing elements as given below. Returns an Email::MIME email.
+
+=over 4
+
+=item _template_, _parameters_
+
+Templated body text and an associative array of template parameters. _template
+contains optional substititutions <?=$values['name']?>, each of which is
+replaced by the value of the corresponding named value in _parameters_. It is
+an error to use a substitution when the corresponding parameter is not present
+or undefined. The first line of the template will be interpreted as contents of
+the Subject: header of the mail if it begins with the literal string 'Subject:
+' followed by a blank line. The templated text will be word-wrapped to produce
+lines of appropriate length.
+
+=item _attachments_
+
+An arrayref of hashrefs that can be passed to Email::MIME.
+
+=item To
+
+Contents of the To: header, as a literal UTF-8 string or an array of addresses
+or [address, name] pairs.
+
+=item From
+
+Contents of the From: header, as an email address or an [address, name] pair.
+
+=item Cc
+
+Contents of the Cc: header, as for To.
+
+=item Reply-To
+
+Contents of the Reply-To: header, as for To.
+
+=item Subject
+
+Contents of the Subject: header, as a UTF-8 string.
+
+=item I<any other element>
+
+interpreted as the literal value of a header with the same name.
+
+=back
+
+If no Date is given, the current date is used. If no To is given, then the
+string "Undisclosed-Recipients: ;" is used. It is an error to fail to give a
+templated body, From or Subject (perhaps from the template).
+
+=cut
+sub construct_email ($) {
+    my $p = shift;
+
+    throw mySociety::Email::Error("Must specify both '_template_' and '_parameters_'")
+        if !exists($p->{_template_}) || !exists($p->{_parameters_});
+    throw mySociety::Email::Error("Template parameters '_parameters_' must be an associative array")
+        if (ref($p->{_parameters_}) ne 'HASH');
+
+    (my $subject, $body) = mySociety::Email::do_template_substitution($p->{_template_}, $p->{_parameters_}, '');
+    $p->{Subject} = $subject if defined($subject);
+
+    if (!exists($p->{Subject})) {
+        # XXX Try to find out what's causing this very occasionally
+        (my $error = $body) =~ s/\n/ | /g;
+        $error = "missing field 'Subject' in MESSAGE - $error";
+        throw mySociety::Email::Error($error);
+    }
+    throw mySociety::Email::Error("missing field 'From' in MESSAGE") unless exists($p->{From});
+
+    # Construct email headers
+    my %hdr;
+
+    foreach my $h (grep { exists($p->{$_}) } qw(To Cc Reply-To)) {
+        if (ref($p->{$h}) eq '') {
+            # Interpret as a literal string in UTF-8, so all we need to do is
+            # escape it.
+            $hdr{$h} = $p->{$h};
+        } elsif (ref($p->{$h}) eq 'ARRAY') {
+            # Array of addresses or [address, name] pairs.
+            $hdr{$h} = join(', ', map { mailbox($_, $h) } @{$p->{$h}});
+        } else {
+            throw mySociety::Email::Error("Field '$h' in MESSAGE should be single value or an array");
+        }
+    }
+
+    foreach my $h (grep { exists($p->{$_}) } qw(From Sender)) {
+        $hdr{$h} = mailbox($p->{$h}, $h);
+    }
+
+    # Some defaults
+    $hdr{To} ||= 'Undisclosed-recipients: ;';
+    $hdr{Date} ||= POSIX::strftime("%a, %d %h %Y %T %z", localtime(time()));
+
+    # Other headers, including Subject
+    foreach (keys(%$p)) {
+        $hdr{$_} = $p->{$_} if ($_ !~ /^_/ && !exists($hdr{$_}));
+    }
+
+    my $parts = [
+        _mime_create(
+            body_str => $body,
+            attributes => {
+                charset => 'utf-8',
+                encoding => 'quoted-printable',
+            },
+        ),
+    ];
+
+    if ($p->{_attachments_}) {
+        push @$parts, map { _mime_create(%$_) } @{$p->{_attachments_}};
+    }
+
+    my $email = Email::MIME->create(
+        header_str => [ %hdr ],
+        parts => $parts,
+        attributes => {
+            charset => 'utf-8',
+        },
+    );
+
+    return $email;
+}
+
+# Handle being given a string, or an arrayref of [ name, email ]
+sub mailbox {
+    my ($e, $header) = @_;
+    if (ref($e) eq '') {
+        return $e;
+    } elsif (ref($e) ne 'ARRAY' || @$e != 2) {
+        throw mySociety::Email::Error("'$header' field should be string or 2-element array");
+    } else {
+        return Email::Address->new($e->[1], $e->[0]);
+    }
+}
+
+# Don't want Date/MIME-Version headers that Email::MIME adds to all parts
+sub _mime_create {
+    my %h = @_;
+    my $e = Email::MIME->create(%h);
+    $e->header_set('Date');
+    $e->header_set('MIME-Version');
+    return $e;
 }
 
 1;