site/cgi-bin/modules/BSE/ComposeMail.pm

   1 package BSE::ComposeMail;
   2 use strict;
   3 use BSE::Template;
   4 use BSE::Mail;
   5 use Carp 'confess';
   6 use Digest::MD5 qw(md5_hex);
   7 use BSE::Variables;
   8
   9 our $VERSION = "1.009";
  10
  11 =head1 NAME
  12
  13 BSE::ComposeMail - compose mail for BSE
  14
  15 =head1 SYNOPSIS
  16
  17   # make an object
  18   my $mailer = BSE::ComposeMail->new(cfg => $cfg);
  19
  20   # simple stuff
  21   # to can either be an email (assumed to be a sysadmin email)
  22   # or a member object (used to determine text or text and html)
  23   # but this text vs mixed is unimplemented for now
  24   $mailer->send(to       => $member_object,
  25                 subject  => $subject,
  26                 template => $template,
  27                 acts     => \%acts,
  28                 # from   => $from,
  29                 # html_template => $html_template # def $template."_html"
  30                 # vars   => \%vars,
  31                 ) or die $mailer->errstr;
  32
  33   # more complex
  34   $mailer->start( ... parameters as above ...);
  35
  36   # attach a file
  37   my $cidurl = $mailer->attach(file => $filename,
  38                                # disposition => 'attachment',
  39                                # display     => $filename,
  40                                # type        => 'application/octet-stream'
  41                                ) or die $mailer->errstr;
  42   # display required unless disposition set to other than "attachment"
  43   my $cidurl2 = $mailer->attach(fh => $fh,
  44                                 display => $display_filename,
  45                                 ...);
  46   my $cidurl3 = $mailer->attach(data => $data,
  47                                 display => $display_filename,
  48                                 ...);
  49
  50   # encrypt and sign
  51   $mailer->encrypt_body(signing_id => $id,
  52                         passphrase => $passphrase);
  53
  54   # encrypt unsigned
  55   $mailer->encrypt_body(signing_id => '');
  56
  57   # encrypt signed based on the [shop].crypt_signing_id
  58   $mailer->encrypt_body();
  59
  60   # and send it
  61   $mailer->done() or die $mailer->errstr;
  62
  63 =cut
  64
  65 sub new {
  66   my ($class, %opts) = @_;
  67
  68   $opts{cfg} ||= BSE::Cfg->single;
  69
  70   bless \%opts, $class;
  71 }
  72
  73 sub send {
  74   my ($self, %opts) = @_;
  75
  76   $self->start(%opts)
  77     and $self->done();
  78 }
  79
  80 sub start {
  81   my ($self, %opts) = @_;
  82
  83   for my $arg (qw(acts template to subject)) {
  84     unless ($opts{$arg}) {
  85       confess "Argument $arg missing\n";
  86     }
  87     $self->{$arg} = $opts{$arg};
  88   }
  89
  90   $self->{from} = $opts{from}
  91     || $self->{cfg}->entry('shop', 'from', $Constants::SHOP_FROM);
  92
  93   $self->{html_template} = $opts{html_template}
  94     || "$self->{template}_html";
  95
  96   $self->{extra_mail_args} = {};
  97   for my $arg (qw(to_name from_name cc bcc)) {
  98     defined $opts{$arg}
  99       and $self->{extra_mail_args}{$arg} = $opts{$arg};
 100   }
 101
 102   $self->{content} = '';
 103   $self->{type} = '';
 104   unless (defined $self->{allow_html}) {
 105     if (ref $self->{to}) {
 106       # being sent to a site user, use their setting
 107       $opts{log_object} ||= $self->{to};
 108       $self->{allow_html} = $self->{to}->allow_html_email;
 109       $self->{to} = $self->{to}{email};
 110     }
 111     else {
 112       $self->{allow_html} =
 113         $self->{cfg}->entry('mail', 'html_system_email', 0);
 114     }
 115   }
 116
 117   delete $self->{baseid};
 118   $self->{attachments} = [];
 119   $self->{encrypt} = 0;
 120
 121   $self->{log} =
 122     {
 123      actor => "S",
 124      component => "composemail::send",
 125     };
 126   for my $key (keys %opts) {
 127     if ($key =~ /^log_(\w+)$/) {
 128       $self->{log}{$1} = $opts{$key};
 129     }
 130   }
 131
 132   my $weak = $self;
 133   Scalar::Util::weaken($weak);
 134   $self->{vars} =
 135     {
 136      bse => BSE::Variables->variables(),
 137      cfg => $self->{cfg},
 138      set_subject => sub {
 139        $self->{subject} = $_[0];
 140      },
 141      ( $opts{vars} ? %{$opts{vars}} : () ),
 142     };
 143
 144   1;
 145 }
 146
 147 sub _gen_id {
 148   my ($self) = @_;
 149
 150   unless ($self->{baseid}) {
 151     # something sort of random
 152     $self->{baseid} = md5_hex(join(",", time, map rand, 0..15));
 153     $self->{idseq} = 0;
 154   }
 155
 156   return $self->{baseid} . "." . ++$self->{idseq};
 157 }
 158
 159 sub attach {
 160   my ($self, %opts) = @_;
 161
 162   my $disp = $opts{disposition} || 'attachment';
 163   my $display = $opts{display};
 164   if ($disp eq 'attachment' && !$display) {
 165     if ($opts{file}) {
 166       ($display = $opts{file}) =~ s!.*[/:\\]!!;
 167       $display =~ tr/a-zA-Z_./_/cs;
 168     }
 169     else {
 170       $self->{errstr} = "You must supply display to attach() if you don't supply file";
 171       return;
 172     }
 173   }
 174
 175   if ($opts{file}) {
 176     # don't attach the same file twice if we can avoid it
 177     for my $attachment (@{$self->{attachments}}) {
 178       if ($attachment->{file} && $attachment->{file} eq $opts{file}) {
 179         return $attachment->{url};
 180       }
 181     }
 182   }
 183
 184   my $id = $self->_gen_id;
 185   my $url = "cid:$id";
 186   my $type = $opts{type} || 'application/octet-stream';
 187
 188   if ($opts{file}) {
 189     unless (-e $opts{file}) {
 190       $self->{errstr} = "Attachment file $opts{file} doesn't exist";
 191       return;
 192     }
 193
 194     push @{$self->{attachments}},
 195       {
 196        file => $opts{file},
 197        disposition => $disp,
 198        display => $display,
 199        id => $id,
 200        url => $url,
 201        type => $type
 202       };
 203   }
 204   elsif ($opts{fh}) {
 205     push @{$self->{attachments}},
 206       {
 207        fh => $opts{fh},
 208        disposition => $disp,
 209        display => $display,
 210        id => $id,
 211        url => $url,
 212        type => $type
 213       };
 214   }
 215   elsif ($opts{data}) {
 216     push @{$self->{attachments}},
 217       {
 218        data => $opts{data},
 219        disposition => $disp,
 220        display => $display,
 221        id => $id,
 222        url => $url,
 223        type => $type
 224       };
 225   }
 226   else {
 227     $self->{errstr} = "No file/fh/data supplied to attach()";
 228     return;
 229   }
 230
 231   return $url;
 232 }
 233
 234 sub encrypt_body {
 235   my ($self, %opts) = @_;
 236
 237   $self->{encrypt} = 1;
 238   $self->{signing_id} = $opts{signing_id};
 239   $self->{passphrase} = $opts{passphrase};
 240   $self->{crypt_recipient} = $opts{recipient};
 241 }
 242
 243 sub _build_internal {
 244   my ($self, $content, $text_type, $headers) = @_;
 245
 246   my $message;
 247   if (@{$self->{attachments}}) {
 248
 249     my $boundary = $self->{baseid}."boundary";
 250     push @$headers, "MIME-Version: 1.0";
 251     push @$headers, qq!Content-Type: multipart/mixed; boundary="$boundary"!;
 252
 253     $message = <<EOS;
 254 --$boundary
 255 Content-Type: $text_type
 256 Content-Disposition: inline
 257
 258 $content
 259 EOS
 260     for my $attachment (@{$self->{attachments}}) {
 261       my $data;
 262       if ($attachment->{file}) {
 263         if (open DATA, "< $attachment->{file}") {
 264           binmode DATA;
 265           $data = do { local $/; <DATA> };
 266           close DATA;
 267         }
 268         else {
 269           $self->{errstr} = "Could not open attachment $attachment->{file}: $!";
 270           return;
 271         }
 272       }
 273       elsif ($attachment->{fh}) {
 274         my $fh = $attachment->{fh};
 275         binmode $fh;
 276         $data = do { local $/; <$fh> };
 277       }
 278       elsif ($attachment->{data}) {
 279         $data = $attachment->{data};
 280       }
 281       else {
 282         confess "Internal error: attachment with no file/fh/data";
 283       }
 284
 285       my $is_text = $attachment->{type} =~ m!^text/!
 286         && $data =~ tr/ -~\r\n\t//c;
 287
 288       my $encoding;
 289       my $encoded;
 290       # we might add 7bit here at some point
 291       if ($is_text) {
 292         require MIME::QuotedPrint;
 293         $encoded = MIME::QuotedPrint::encode_qp($data);
 294         $encoding = 'quoted-printable';
 295       }
 296       else {
 297         require MIME::Base64;
 298         $encoded = MIME::Base64::encode_base64($data);
 299         $encoding = 'base64';
 300       }
 301       my $disp = $attachment->{disposition};
 302       if ($disp eq 'attachment') {
 303         $disp .= qq!; filename="$attachment->{display}"!;
 304       }
 305       $message .= <<EOS;
 306 --$boundary
 307 Content-Type: $attachment->{type}
 308 Content-Transfer-Encoding: $encoding
 309 Content-Disposition: $disp
 310 Content-Id: <$attachment->{id}>
 311
 312 $encoded
 313 EOS
 314     }
 315     $message =~ /\n\z/ or $message .= "\n";
 316     $message .= "--$boundary--\n";
 317   }
 318   else {
 319     push @$headers,
 320       "Content-Type: $text_type",
 321         "MIME-Version: 1.0";
 322     $message = $content;
 323   }
 324
 325   return $message;
 326 }
 327
 328 sub _build_mime_lite {
 329   my ($self, $text_content, $html_content, $headers) = @_;
 330
 331   require MIME::Lite;
 332
 333   $text_content .= "\n" unless $text_content =~ /\n$/;
 334   $html_content .= "\n" unless $html_content =~ /\n$/;
 335
 336   my $msg = MIME::Lite->new
 337     (
 338      From => $self->{from},
 339      "Errors-To:" => $self->{from},
 340      Subject => $self->{subject},
 341      Type => 'multipart/alternative',
 342     );
 343   my $text_part = $msg->attach
 344     (
 345      Type => 'text/plain',
 346      Data => [ $text_content ],
 347      $text_content =~ /.{79}/ || $text_content =~ /[^ -~\x0d\x0a]/
 348      ? ( Encoding => 'quoted-printable' ) : (),
 349     );
 350   my $html_part = $msg->attach(Type => 'multipart/related');
 351   $html_part->attach
 352     (
 353      Type => 'text/html',
 354      Data => $html_content,
 355      Encoding => 'quoted-printable',
 356     );
 357
 358   for my $attachment (@{$self->{attachments}}) {
 359     my $data;
 360     if ($attachment->{file}) {
 361       if (open DATA, "< $attachment->{file}") {
 362         binmode DATA;
 363         $data = do { local $/; <DATA> };
 364         close DATA;
 365       }
 366       else {
 367         $self->{errstr} = "Could not open attachment $attachment->{file}: $!";
 368         return;
 369       }
 370     }
 371     elsif ($attachment->{fh}) {
 372       my $fh = $attachment->{fh};
 373       binmode $fh;
 374       $data = do { local $/; <$fh> };
 375     }
 376     elsif ($attachment->{data}) {
 377       $data = $attachment->{data};
 378     }
 379     else {
 380       confess "Internal error: attachment with no file/fh/data";
 381     }
 382     my %opts =
 383       (
 384        Type => $attachment->{type},
 385        Data => $data,
 386        Id   => "<$attachment->{id}>" # <> required by RFC
 387       );
 388     if ($attachment->{disposition} eq 'attachment' || $attachment->{display}) {
 389       $opts{Filename} = $attachment->{display};
 390     }
 391     $html_part->attach(%opts);
 392   }
 393
 394   my $header_str = $msg->header_as_string;
 395   for my $header (split /\n/, $header_str) {
 396     my ($key, $value) = $header =~ /^([^:]+): *(.*)/
 397       or next;
 398     # the mailer adds these in later
 399     unless ($key =~ /^(from|to|subject)$/i) {
 400       push @$headers, $header;
 401     }
 402   }
 403
 404   return $msg->body_as_string;
 405 }
 406
 407 sub extra_headers {
 408   my ($self) = @_;
 409
 410   my $section = $self->{header_section} || "mail headers for $self->{template}";
 411   my @headers;
 412   my %extras = $self->{cfg}->entriesCS($section);
 413   for my $key (keys %extras) {
 414     (my $head_key = $key) =~ s/_/-/g;
 415     push @headers, "$head_key: $extras{$key}";
 416   }
 417
 418   return @headers;
 419 }
 420
 421 sub _log_dump {
 422   my ($self, $headers, $message) = @_;
 423
 424   my $max = $self->{cfg}->entry("audit log", "mail_max_dump", 50000);
 425   my $msg = "$headers\n\n$message";
 426   if (length($msg) > $max) {
 427     substr($msg, $max-3) = "...";
 428   }
 429
 430   return $msg;
 431 }
 432
 433 sub done {
 434   my ($self) = @_;
 435
 436   my %acts =
 437     (
 438      %{$self->{acts}},
 439      resource => [ tag_resource => $self ],
 440      set_subject => [ tag_set_subject => $self ],
 441     ); #
 442
 443   my $message;
 444   my @headers;
 445   my $content = BSE::Template->
 446     get_page($self->{template}, $self->{cfg}, \%acts, undef, undef, $self->{vars});
 447   if (!$self->{allow_html} || $self->{encrypt} ||
 448       !BSE::Template->find_source($self->{html_template}, $self->{cfg})) {
 449     my $text_type = 'text/plain';
 450     if ($self->{encrypt}) {
 451       $content = $self->_encrypt($content, \$text_type);
 452       $content
 453         or return;
 454     }
 455     $message = $self->_build_internal($content, $text_type, \@headers);
 456   }
 457   else {
 458     my $html_content = BSE::Template->
 459       get_page($self->{html_template}, $self->{cfg}, \%acts, undef, undef, $self->{vars});
 460
 461     my $inline_css = $self->{cfg}->entry("mail", "inline_css", "style");
 462     if (($inline_css eq "style" && $html_content =~ /<style/i)
 463         || $inline_css eq "force") {
 464       my $report_failure = $self->{cfg}->entry("mail", "inline_css_report", 1);
 465       my %inline_opts = map { $_ => 1 } split /,/,
 466         $self->{cfg}->entry("mail", "inline_css_flags", "");
 467       my $good = eval {
 468         require CSS::Inliner;
 469         my $inliner = CSS::Inliner->new(\%inline_opts);
 470         local $SIG{__DIE__};
 471         $inliner->read({html => $html_content});
 472         $html_content = $inliner->inlinify;
 473         1;
 474       };
 475       if (!$good && $report_failure) {
 476         my $error = $@;
 477         require BSE::TB::AuditLog;
 478         my %log = %{$self->{log}};
 479         my $dump = <<DUMP;
 480 HTML:
 481 ======
 482 $html_content
 483 ======
 484 Error:
 485 ======
 486 $error
 487 ======
 488 DUMP
 489         BSE::TB::AuditLog->log
 490             (
 491              %log,
 492              msg => "Error inlining CSS",
 493              component => "composemail:done:inlinecss",
 494              level => "error",
 495              dump => $dump,
 496             );
 497       }
 498     }
 499
 500     $message = $self->_build_mime_lite($content, $html_content, \@headers);
 501   }
 502   push @headers, $self->extra_headers;
 503   my $mailer = BSE::Mail->new(cfg => $self->{cfg});
 504   my $headers = join "", map "$_\n", @headers;
 505   my %extras;
 506   if ($mailer->send(to => $self->{to},
 507                     from => $self->{from},
 508                     subject => $self->{subject},
 509                     body => $message,
 510                     headers => $headers,
 511                     %{$self->{extra_mail_args}})) {
 512     if ($self->{cfg}->entry("audit log", "mail", 0)) {
 513       my %log_opts = %{$self->{log}};
 514       $log_opts{msg} ||= "Mail sent to $self->{to}";
 515       $log_opts{component} ||= "composemail:done:send";
 516       $log_opts{level} ||= "info";
 517       $log_opts{actor} ||= "S";
 518       $log_opts{dump} =$self->_log_dump($headers, $message);
 519       require BSE::TB::AuditLog;
 520       BSE::TB::AuditLog->log(%log_opts);
 521     }
 522     return 1;
 523   }
 524   else {
 525     my %log_opts = %{$self->{log}};
 526     $log_opts{msg} = "Error sending email: " . $mailer->errstr;
 527     $log_opts{component} ||= "composemail:done:send";
 528     $log_opts{level} ||= "error";
 529     $log_opts{actor} ||= "S";
 530     $log_opts{dump} = $self->_log_dump($headers, $message);
 531     require BSE::TB::AuditLog;
 532     BSE::TB::AuditLog->log(%log_opts);
 533
 534     $self->{errstr} = "Send error: ", $mailer->errstr;
 535     print STDERR "Error sending mail ", $mailer->errstr, "\n";
 536     return;
 537   }
 538 }
 539
 540 sub _encrypt {
 541   my ($self, $content, $rtype) = @_;
 542
 543   my $cfg = $self->{cfg};
 544
 545   my $crypt_class = $cfg->entry('shop', 'crypt_module',
 546                                 $Constants::SHOP_CRYPTO);
 547   my $signing_id = defined($self->{signing_id}) ? $self->{signing_id}
 548     : $cfg->entry('shop', 'crypt_signing_id',
 549                    $Constants::SHOP_SIGNING_ID);
 550   my $passphrase = defined($self->{passphrase}) ? $self->{passphrase}
 551     : $cfg->entry('shop', 'crypt_passphrase', $Constants::SHOP_PASSPHRASE);
 552   my $gpg = $cfg->entry('shop', 'crypt_gpg', $Constants::SHOP_GPG);
 553   my $pgp = $cfg->entry('shop', 'crypt_pgp', $Constants::SHOP_PGP);
 554   my $pgpe = $cfg->entry('shop', 'crypt_pgpe', $Constants::SHOP_PGPE);
 555
 556   (my $class_file = $crypt_class.".pm") =~ s!::!/!g;
 557   require $class_file;
 558   my $encryptor = $crypt_class->new;
 559   my %opts =
 560     (
 561      passphrase => $passphrase,
 562      stripwarn => 1,
 563      debug => $cfg->entry('debug', 'mail_encryption', 0),
 564      sign => !!$signing_id,
 565      secretkeyid => $signing_id,
 566      pgp => $pgp,
 567      pgpe => $pgpe,
 568      gpg => $gpg,
 569     );
 570
 571   my $recip = $self->{crypt_recipient} || $self->{to};
 572
 573   my $result = $encryptor->encrypt($recip, $content, %opts);
 574   unless ($result) {
 575     my $dump = $encryptor->can("dump") ? $encryptor->dump : "See error log";
 576     require BSE::TB::AuditLog;
 577     BSE::TB::AuditLog->log
 578         (
 579          %{$self->{log}},
 580          msg => "Error encrypting content: " . $encryptor->error,
 581          level => "crit",
 582          component => "composemail:done:encrypt",
 583          dump => $dump,
 584         );
 585     $self->{errstr} = "Error encrypting: " . $encryptor->error;
 586     return;
 587   }
 588
 589   if ($cfg->entry('shop', 'crypt_content_type', 0)) {
 590     $$rtype = 'application/pgp; format=text; x-action=encrypt';
 591   }
 592
 593   $result;
 594 }
 595
 596 sub errstr {
 597   $_[0]{errstr};
 598 }
 599
 600 sub tag_resource {
 601   my ($self, $args) = @_;
 602
 603   defined $args and $args =~ /^\w+$/
 604     or return "** invalid resource id $args **";
 605
 606   if ($self->{resource}{$args}) {
 607     return $self->{resource}{$args};
 608   }
 609
 610   my $res_entry = $self->{cfg}->entry('mail resources', $args)
 611     or return "** No resource $args found **";
 612   my ($filename, $type, $inline) = split /,/, $res_entry;
 613
 614   unless ($type) {
 615     if ($filename =~ /\.(gif|png|jpg)$/i) {
 616       $type = lc $1 eq 'jpg' ? 'image/jpeg' : 'image/' . lc $1;
 617     }
 618     else {
 619       $type = 'application/octet-stream';
 620     }
 621   }
 622   if (!defined $inline) {
 623     $inline = $type =~ m!^image/!;
 624   }
 625
 626   my $abs_filename = BSE::Template->find_source($filename, $self->{cfg})
 627     or return "** file $filename for resource $args not found **";
 628
 629   (my $display = $filename) =~ s/.*[\/\\]//;
 630
 631   my $url = $self->attach(file => $abs_filename,
 632                           display => $display,
 633                           type => $type,
 634                           inline => $inline)
 635     or return "** could not attach $args: $self->{errstr} **";
 636
 637   $self->{resource}{$args} = $url;
 638
 639   return $url;
 640 }
 641
 642 sub tag_set_subject {
 643   my ($self, $args, $acts, $tag, $templater) = @_;
 644
 645   my @args = DevHelp::Tags->get_parms($args, $acts, $templater);
 646
 647   $self->{subject} = "@args";
 648
 649   return '';
 650 }
 651
 652 sub send_simple {
 653   my ($class, %opts) = @_;
 654
 655   my $cfg = BSE::Cfg->single;
 656   my $mailer = $class->new(cfg => $cfg);
 657
 658   my $id = $opts{id}
 659     or confess "No mail id provided";
 660
 661   my $section = "email $id";
 662
 663   for my $key (qw/subject template html_template allow_html from from_name/) {
 664     my $value = $cfg->entry($section, $key);
 665     defined $value and $opts{$key} = $value;
 666   }
 667   unless (defined $opts{acts}) {
 668     require BSE::Util::Tags;
 669     BSE::Util::Tags->import(qw/tag_hash_plain/);
 670     my %acts =
 671       (
 672        BSE::Util::Tags->static(undef, $cfg),
 673       );
 674     if ($opts{extraacts}) {
 675       %acts = ( %acts, %{$opts{extraacts}} );
 676     }
 677     $opts{acts} = \%acts;
 678   }
 679
 680   $mailer->send(%opts)
 681     or print STDERR "Error sending mail $id: ", $mailer->errstr, "\n";
 682
 683   return 1;
 684 }
 685
 686
 687 1;