Allow attachment of emails in email_send

Required by Zurich for mysociety/FixMyStreet-Commercial#675

9 files changed, 285 insertions, 11 deletions

diff --git a/cpanfile b/cpanfile
index d7abc3315..16d431884 100644
--- a/cpanfile
+++ b/cpanfile
@@ -43,6 +43,7 @@ requires 'DBIx::Class::ResultSet';
 requires 'DBIx::Class::Schema::Loader';
 requires 'Digest::MD5';
 requires 'Digest::SHA';
+requires 'Email::MIME';
 requires 'Email::Send';
 requires 'Email::Send::SMTP';
 requires 'Email::Simple';
diff --git a/cpanfile.snapshot b/cpanfile.snapshot
index add5bc404..922738c24 100644
--- a/cpanfile.snapshot
+++ b/cpanfile.snapshot
@@ -2584,6 +2584,63 @@ DISTRIBUTIONS
       ExtUtils::MakeMaker 0
       Test::More 0.47
       Time::Local 0.000
+  Email-MIME-1.929
+    pathname: R/RJ/RJBS/Email-MIME-1.929.tar.gz
+    provides:
+      Email::MIME 1.929
+      Email::MIME::Creator 1.929
+      Email::MIME::Encode 1.929
+      Email::MIME::Header 1.929
+      Email::MIME::Modifier 1.929
+    requirements:
+      Carp 0
+      Email::Address 0
+      Email::MIME::ContentType 1.016
+      Email::MIME::Encodings 1.314
+      Email::MessageID 0
+      Email::Simple 2.102
+      Email::Simple::Creator 0
+      Email::Simple::Header 0
+      Encode 1.9801
+      ExtUtils::MakeMaker 0
+      MIME::Base64 0
+      MIME::Types 1.13
+      Scalar::Util 0
+      parent 0
+      perl 5.008001
+      strict 0
+      warnings 0
+  Email-MIME-ContentType-1.018
+    pathname: R/RJ/RJBS/Email-MIME-ContentType-1.018.tar.gz
+    provides:
+      Email::MIME::ContentType 1.018
+    requirements:
+      Carp 0
+      Exporter 5.57
+      ExtUtils::MakeMaker 0
+      strict 0
+      warnings 0
+  Email-MIME-Encodings-1.315
+    pathname: R/RJ/RJBS/Email-MIME-Encodings-1.315.tar.gz
+    provides:
+      Email::MIME::Encodings 1.315
+    requirements:
+      Carp 0
+      ExtUtils::MakeMaker 6.30
+      MIME::Base64 3.05
+      MIME::QuotedPrint 3.05
+      strict 0
+      warnings 0
+  Email-MessageID-1.405
+    pathname: R/RJ/RJBS/Email-MessageID-1.405.tar.gz
+    provides:
+      Email::MessageID 1.405
+    requirements:
+      ExtUtils::MakeMaker 6.30
+      Sys::Hostname 0
+      overload 0
+      strict 0
+      warnings 0
   Email-Send-2.198
     pathname: R/RJ/RJBS/Email-Send-2.198.tar.gz
     provides:
@@ -2670,6 +2727,9 @@ DISTRIBUTIONS
     pathname: S/SH/SHLOMIF/Error-0.17019.tar.gz
     provides:
       Error 0.17019
+      Error::Simple 0.17019
+      Error::WarnDie undef
+      Error::subs undef
     requirements:
       Module::Build 0.39
       Scalar::Util 0
@@ -3498,6 +3558,20 @@ DISTRIBUTIONS
       ExtUtils::MakeMaker 6.52
       Test::More 0.82
       perl 5.00503
+  MIME-Lite-3.030
+    pathname: R/RJ/RJBS/MIME-Lite-3.030.tar.gz
+    provides:
+      MIME::Lite 3.030
+      MIME::Lite::IO_Handle 3.030
+      MIME::Lite::IO_Scalar 3.030
+      MIME::Lite::IO_ScalarArray 3.030
+      MIME::Lite::SMTP 3.030
+      MailTool undef
+    requirements:
+      Email::Date::Format 1.000
+      ExtUtils::MakeMaker 0
+      File::Basename 0
+      File::Spec 0
   MIME-Types-1.38
     pathname: M/MA/MARKOV/MIME-Types-1.38.tar.gz
     provides:
@@ -5077,6 +5151,7 @@ DISTRIBUTIONS
       IO::Socket::SSL 0
       LWP::UserAgent 0
       MIME::Base64 0
+      MIME::Lite 0
       MIME::Parser 0
       Net::POP3 0
       Scalar::Util 0
diff --git a/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm
index cd05dcb8f..c5d628ab6 100644
--- a/perllib/FixMyStreet/App.pm
+++ b/perllib/FixMyStreet/App.pm
@@ -345,6 +345,10 @@ sub send_email {
         }
     ) };
 
+    if (my $attachments = $extra_stash_values->{attachments}) {
+        $email_text = munge_attachments($email_text, $attachments);
+    }
+
     # send the email
     $c->model('EmailSend')->send($email_text);
 
@@ -395,8 +399,12 @@ sub send_email_cron {
     $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;
+
     if ($nomail) {
         print $email;
         return 1; # Failure
@@ -410,6 +418,44 @@ sub send_email_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;
+}
+
+
 =head2 uri_with
 
     $uri = $c->uri_with( ... );
diff --git a/perllib/FixMyStreet/App/Model/PhotoSet.pm b/perllib/FixMyStreet/App/Model/PhotoSet.pm
index fa6eb060b..5d75b62dc 100644
--- a/perllib/FixMyStreet/App/Model/PhotoSet.pm
+++ b/perllib/FixMyStreet/App/Model/PhotoSet.pm
@@ -71,7 +71,25 @@ sub _jpeg_magic {
     #     and \x{49}\x{49} (Tiff, 3 results in live DB) ?
 }
 
-has images => ( # jpeg data for actual image
+=head2 C<images>, C<num_images>, C<get_raw_image_data>, C<all_images>
+
+C<$photoset-E<GT>images> is an AoA containing the filed and the binary image data.
+
+    [
+        [ $fileid1, $binary_data ],
+        [ $fileid2, $binary_data ],
+        ...
+    ]
+
+Various accessors are provided onto it:
+
+    num_images: count
+    get_raw_image_data ($index): return the [$fileid, $binary_data] tuple
+    all_images: return AoA as an array (e.g. rather than arrayref)
+
+=cut
+
+has images => ( #  AoA of [$fileid, $binary_data] tuples
     isa => 'ArrayRef',
     is => 'rw',
     traits => ['Array'],
diff --git a/perllib/FixMyStreet/SendReport/Email.pm b/perllib/FixMyStreet/SendReport/Email.pm
index 9fec0ac9c..bac408510 100644
--- a/perllib/FixMyStreet/SendReport/Email.pm
+++ b/perllib/FixMyStreet/SendReport/Email.pm
@@ -93,6 +93,11 @@ sub send {
         To => $self->to,
         From => $self->send_from( $row ),
     };
+
+    my $app = FixMyStreet::App->new( cobrand => $cobrand );
+
+    $cobrand->munge_sendreport_params($app, $row, $h, $params) if $cobrand->can('munge_sendreport_params');
+
     $params->{Bcc} = $self->bcc if @{$self->bcc};
 
     if (FixMyStreet::Email::test_dmarc($params->{From}[0])) {
@@ -100,7 +105,7 @@ sub send {
         $params->{From} = [ mySociety::Config::get('CONTACT_EMAIL'), $params->{From}[1] ];
     }
 
-    my $result = FixMyStreet::App->send_email_cron(
+    my $result = $app->send_email_cron(
         $params,
         mySociety::Config::get('CONTACT_EMAIL'),
         $nomail,
diff --git a/perllib/FixMyStreet/TestMech.pm b/perllib/FixMyStreet/TestMech.pm
index ef60b0d36..8325b07a8 100644
--- a/perllib/FixMyStreet/TestMech.pm
+++ b/perllib/FixMyStreet/TestMech.pm
@@ -221,6 +221,24 @@ sub get_email {
     return $emails[0];
 }
 
+=head2 get_first_email
+
+    $email = $mech->get_first_email(@emails);
+
+Returns first email in queue as a string and fails a test if the mail doesn't have a date and epoch-containing Message-ID header.
+
+=cut
+
+sub get_first_email {
+    my $mech = shift;
+    my $email = shift or do { fail 'No email retrieved'; return };
+    my $email_as_string = $email->as_string;
+    ok $email_as_string =~ s{\s+Date:\s+\S.*?$}{}xmsg, "Found and stripped out date";
+    ok $email_as_string =~ s{\s+Message-ID:\s+\S.*?$}{}xmsg, "Found and stripped out message ID (contains epoch)";
+    return $email_as_string;
+}
+
+
 =head2 page_errors
 
     my $arrayref = $mech->page_errors;
diff --git a/t/app/helpers/grey.gif b/t/app/helpers/grey.gif
new file mode 100644
index 000000000..98eee7d12
--- /dev/null
+++ b/t/app/helpers/grey.gif
diff --git a/t/app/helpers/send_email.t b/t/app/helpers/send_email.t
index 14c7d363b..d1609cb2f 100644
--- a/t/app/helpers/send_email.t
+++ b/t/app/helpers/send_email.t
@@ -9,12 +9,16 @@ BEGIN {
     FixMyStreet->test_mode(1);
 }
 
-use Test::More tests => 5;
+use Test::More;
+use Test::LongString;
 
 use Catalyst::Test 'FixMyStreet::App';
 
 use Email::Send::Test;
-use Path::Class;
+use Path::Tiny;
+
+use FixMyStreet::TestMech;
+my $mech = FixMyStreet::TestMech->new;
 
 my $c = ctx_request("/");
 
@@ -33,16 +37,66 @@ my @emails = Email::Send::Test->emails;
 is scalar(@emails), 1, "caught one email";
 
 # Get the email, check it has a date and then strip it out
-my $email_as_string = $emails[0]->as_string;
-ok $email_as_string =~ s{\s+Date:\s+\S.*?$}{}xms, "Found and stripped out date";
-ok $email_as_string =~ s{\s+Message-ID:\s+\S.*?$}{}xms, "Found and stripped out message ID (contains epoch)";
+my $email_as_string = $mech->get_first_email(@emails);
 
-my $expected_email_content =   file(__FILE__)->dir->file('send_email_sample.txt')->slurp;
+my $expected_email_content =   path(__FILE__)->parent->child('send_email_sample.txt')->slurp;
 my $name = FixMyStreet->config('CONTACT_NAME');
 $name = "\"$name\"" if $name =~ / /;
 my $sender = $name . ' <' . FixMyStreet->config('DO_NOT_REPLY_EMAIL') . '>';
 $expected_email_content =~ s{CONTACT_EMAIL}{$sender};
 
-is $email_as_string,
-$expected_email_content,
-  "email is as expected";
+is_string $email_as_string, $expected_email_content, "email is as expected";
+
+subtest 'MIME attachments' => sub {
+    my $data = path(__FILE__)->parent->child('grey.gif')->slurp_raw;
+
+    Email::Send::Test->clear;
+    my @emails = Email::Send::Test->emails;
+    is scalar(@emails), 0, "reset";
+
+    ok $c->send_email( 'test.txt',
+        { to => 'test@recipient.com',
+          attachments => [
+             {
+                body => $data,
+                attributes => {
+                    filename => 'foo.gif',
+                    content_type => 'image/gif',
+                    encoding => 'quoted-printable',
+                    name => 'foo.gif',
+                },
+             },
+             {
+                body => $data,
+                attributes => {
+                    filename => 'bar.gif',
+                    content_type => 'image/gif',
+                    encoding => 'quoted-printable',
+                    name => 'bar.gif',
+                },
+             },
+         ]
+        } ), "sent an email with MIME attachments";
+
+    @emails = $mech->get_email;
+    is scalar(@emails), 1, "caught one email";
+
+    my $email_as_string = $mech->get_first_email(@emails);
+
+    my ($boundary) = $email_as_string =~ /boundary="([A-Za-z0-9.]*)"/ms;
+    my $changes = $email_as_string =~ s{$boundary}{}g;
+    is $changes, 5, '5 boundaries'; # header + 4 around the 3x parts (text + 2 images)
+
+    my $expected_email_content = path(__FILE__)->parent->child('send_email_sample_mime.txt')->slurp;
+    $expected_email_content =~ s{CONTACT_EMAIL}{$sender}g;
+
+    is_string $email_as_string, $expected_email_content, 'MIME email text ok'
+        or do {
+            (my $test_name = $0) =~ s{/}{_}g;
+            my $path = path("test-output-$test_name.tmp");
+            $path->spew($email_as_string);
+            diag "Saved output in $path";
+        };
+};
+
+done_testing;
diff --git a/t/app/helpers/send_email_sample_mime.txt b/t/app/helpers/send_email_sample_mime.txt
new file mode 100644
index 000000000..4ce0f9520
--- /dev/null
+++ b/t/app/helpers/send_email_sample_mime.txt
@@ -0,0 +1,57 @@
+MIME-Version: 1.0
+Subject: test email =?utf-8?Q?=E2=98=BA?=
+Content-Type: multipart/mixed; boundary=""
+To: test@recipient.com
+Content-Transfer-Encoding: 7bit
+From: CONTACT_EMAIL
+
+
+--
+MIME-Version: 1.0
+Subject: test email =?utf-8?Q?=E2=98=BA?=
+Content-Type: text/plain; charset="utf-8"
+To: test@recipient.com
+Content-Transfer-Encoding: quoted-printable
+From: CONTACT_EMAIL
+
+Hello,
+
+This is a test email where foo: bar.
+
+utf8: =E6=88=91=E4=BB=AC=E5=BA=94=E8=AF=A5=E8=83=BD=E5=A4=9F=E6=97=A0=E7=BC=
+=9D=E5=A4=84=E7=90=86UTF8=E7=BC=96=E7=A0=81
+
+  indented_text
+
+long line: Lorem ipsum dolor sit amet, consectetur adipisicing elit,
+sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.
+Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris
+nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in
+reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla
+pariatur. Excepteur sint occaecat cupidatat non proident, sunt in
+culpa qui officia deserunt mollit anim id est laborum.
+
+Yours,=20=20
+FixMyStreet.=20=
+
+
+
+--
+MIME-Version: 1.0
+Content-Type: image/gif; name="foo.gif"
+Content-Disposition: inline; filename="foo.gif"
+Content-Transfer-Encoding: quoted-printable
+
+GIF89a=01=00=01=00=80=00=00=00=00=00=CC=CC=CC,=00=00=00=00=01=00=01=00=00=
+=02=01L=00;=
+
+--
+MIME-Version: 1.0
+Content-Type: image/gif; name="bar.gif"
+Content-Disposition: inline; filename="bar.gif"
+Content-Transfer-Encoding: quoted-printable
+
+GIF89a=01=00=01=00=80=00=00=00=00=00=CC=CC=CC,=00=00=00=00=01=00=01=00=00=
+=02=01L=00;=
+
+----