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.010";
  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 $charset = $self->{cfg}->charset;
 337
 338   my $msg = MIME::Lite->new
 339     (
 340      From => $self->{from},
 341      "Errors-To:" => $self->{from},
 342      Subject => $self->{subject},
 343      Type => 'multipart/alternative',
 344     );
 345   my $text_part = $msg->attach
 346     (
 347      Type => "text/plain; charset=$charset",
 348      Data => [ $text_content ],
 349      $text_content =~ /.{79}/ || $text_content =~ /[^ -~\x0d\x0a]/
 350      ? ( Encoding => 'quoted-printable' ) : (),
 351     );
 352   my $html_part = $msg->attach(Type => 'multipart/related');
 353   $html_part->attach
 354     (
 355      Type => BSE::Template->html_type($self->{cfg}),
 356      Data => $html_content,
 357      Encoding => 'quoted-printable',
 358     );
 359
 360   for my $attachment (@{$self->{attachments}}) {
 361     my $data;
 362     if ($attachment->{file}) {
 363       if (open DATA, "< $attachment->{file}") {
 364         binmode DATA;
 365         $data = do { local $/; <DATA> };
 366         close DATA;
 367       }
 368       else {
 369         $self->{errstr} = "Could not open attachment $attachment->{file}: $!";
 370         return;
 371       }
 372     }
 373     elsif ($attachment->{fh}) {
 374       my $fh = $attachment->{fh};
 375       binmode $fh;
 376       $data = do { local $/; <$fh> };
 377     }
 378     elsif ($attachment->{data}) {
 379       $data = $attachment->{data};
 380     }
 381     else {
 382       confess "Internal error: attachment with no file/fh/data";
 383     }
 384     my %opts =
 385       (
 386        Type => $attachment->{type},
 387        Data => $data,
 388        Id   => "<$attachment->{id}>" # <> required by RFC
 389       );
 390     if ($attachment->{disposition} eq 'attachment' || $attachment->{display}) {
 391       $opts{Filename} = $attachment->{display};
 392     }
 393     $html_part->attach(%opts);
 394   }
 395
 396   my $header_str = $msg->header_as_string;
 397   for my $header (split /\n/, $header_str) {
 398     my ($key, $value) = $header =~ /^([^:]+): *(.*)/
 399       or next;
 400     # the mailer adds these in later
 401     unless ($key =~ /^(from|to|subject)$/i) {
 402       push @$headers, $header;
 403     }
 404   }
 405
 406   return $msg->body_as_string;
 407 }
 408
 409 sub extra_headers {
 410   my ($self) = @_;
 411
 412   my $section = $self->{header_section} || "mail headers for $self->{template}";
 413   my @headers;
 414   my %extras = $self->{cfg}->entriesCS($section);
 415   for my $key (keys %extras) {
 416     (my $head_key = $key) =~ s/_/-/g;
 417     push @headers, "$head_key: $extras{$key}";
 418   }
 419
 420   return @headers;
 421 }
 422
 423 sub _log_dump {
 424   my ($self, $headers, $message) = @_;
 425
 426   my $max = $self->{cfg}->entry("audit log", "mail_max_dump", 50000);
 427   my $msg = "$headers\n\n$message";
 428   if (length($msg) > $max) {
 429     substr($msg, $max-3) = "...";
 430   }
 431
 432   return $msg;
 433 }
 434
 435 sub done {
 436   my ($self) = @_;
 437
 438   my %acts =
 439     (
 440      %{$self->{acts}},
 441      resource => [ tag_resource => $self ],
 442      set_subject => [ tag_set_subject => $self ],
 443     ); #
 444
 445   my $message;
 446   my @headers;
 447   my $content = BSE::Template->
 448     get_page($self->{template}, $self->{cfg}, \%acts, undef, undef, $self->{vars});
 449
 450   $content = BSE::Template->encode_content($content, $self->{cfg});
 451
 452   if (!$self->{allow_html} || $self->{encrypt} ||
 453       !BSE::Template->find_source($self->{html_template}, $self->{cfg})) {
 454     my $text_type = 'text/plain';
 455     if ($self->{encrypt}) {
 456       $content = $self->_encrypt($content, \$text_type);
 457       $content
 458         or return;
 459     }
 460     $message = $self->_build_internal($content, $text_type, \@headers);
 461   }
 462   else {
 463     my $html_content = BSE::Template->
 464       get_page($self->{html_template}, $self->{cfg}, \%acts, undef, undef, $self->{vars});
 465
 466     my $inline_css = $self->{cfg}->entry("mail", "inline_css", "style");
 467     if (($inline_css eq "style" && $html_content =~ /<style/i)
 468         || $inline_css eq "force") {
 469       my $report_failure = $self->{cfg}->entry("mail", "inline_css_report", 1);
 470       my %inline_opts = map { $_ => 1 } split /,/,
 471         $self->{cfg}->entry("mail", "inline_css_flags", "");
 472       my $good = eval {
 473         require CSS::Inliner;
 474         my $inliner = CSS::Inliner->new(\%inline_opts);
 475         local $SIG{__DIE__};
 476         $inliner->read({html => $html_content});
 477         $html_content = $inliner->inlinify;
 478         1;
 479       };
 480       if (!$good && $report_failure) {
 481         my $error = $@;
 482         require BSE::TB::AuditLog;
 483         my %log = %{$self->{log}};
 484         my $dump = <<DUMP;
 485 HTML:
 486 ======
 487 $html_content
 488 ======
 489 Error:
 490 ======
 491 $error
 492 ======
 493 DUMP
 494         BSE::TB::AuditLog->log
 495             (
 496              %log,
 497              msg => "Error inlining CSS",
 498              component => "composemail:done:inlinecss",
 499              level => "error",
 500              dump => $dump,
 501             );
 502       }
 503     }
 504
 505     $html_content = BSE::Template->encode_content($html_content, $self->{cfg});
 506
 507     $message = $self->_build_mime_lite($content, $html_content, \@headers);
 508   }
 509   push @headers, $self->extra_headers;
 510   my $mailer = BSE::Mail->new(cfg => $self->{cfg});
 511   my $headers = join "", map "$_\n", @headers;
 512   my %extras;
 513   if ($mailer->send(to => $self->{to},
 514                     from => $self->{from},
 515                     subject => $self->{subject},
 516                     body => $message,
 517                     headers => $headers,
 518                     %{$self->{extra_mail_args}})) {
 519     if ($self->{cfg}->entry("audit log", "mail", 0)) {
 520       my %log_opts = %{$self->{log}};
 521       $log_opts{msg} ||= "Mail sent to $self->{to}";
 522       $log_opts{component} ||= "composemail:done:send";
 523       $log_opts{level} ||= "info";
 524       $log_opts{actor} ||= "S";
 525       $log_opts{dump} =$self->_log_dump($headers, $message);
 526       require BSE::TB::AuditLog;
 527       BSE::TB::AuditLog->log(%log_opts);
 528     }
 529     return 1;
 530   }
 531   else {
 532     my %log_opts = %{$self->{log}};
 533     $log_opts{msg} = "Error sending email: " . $mailer->errstr;
 534     $log_opts{component} ||= "composemail:done:send";
 535     $log_opts{level} ||= "error";
 536     $log_opts{actor} ||= "S";
 537     $log_opts{dump} = $self->_log_dump($headers, $message);
 538     require BSE::TB::AuditLog;
 539     BSE::TB::AuditLog->log(%log_opts);
 540
 541     $self->{errstr} = "Send error: ", $mailer->errstr;
 542     print STDERR "Error sending mail ", $mailer->errstr, "\n";
 543     return;
 544   }
 545 }
 546
 547 sub _encrypt {
 548   my ($self, $content, $rtype) = @_;
 549
 550   my $cfg = $self->{cfg};
 551
 552   my $crypt_class = $cfg->entry('shop', 'crypt_module',
 553                                 $Constants::SHOP_CRYPTO);
 554   my $signing_id = defined($self->{signing_id}) ? $self->{signing_id}
 555     : $cfg->entry('shop', 'crypt_signing_id',
 556                    $Constants::SHOP_SIGNING_ID);
 557   my $passphrase = defined($self->{passphrase}) ? $self->{passphrase}
 558     : $cfg->entry('shop', 'crypt_passphrase', $Constants::SHOP_PASSPHRASE);
 559   my $gpg = $cfg->entry('shop', 'crypt_gpg', $Constants::SHOP_GPG);
 560   my $pgp = $cfg->entry('shop', 'crypt_pgp', $Constants::SHOP_PGP);
 561   my $pgpe = $cfg->entry('shop', 'crypt_pgpe', $Constants::SHOP_PGPE);
 562
 563   (my $class_file = $crypt_class.".pm") =~ s!::!/!g;
 564   require $class_file;
 565   my $encryptor = $crypt_class->new;
 566   my %opts =
 567     (
 568      passphrase => $passphrase,
 569      stripwarn => 1,
 570      debug => $cfg->entry('debug', 'mail_encryption', 0),
 571      sign => !!$signing_id,
 572      secretkeyid => $signing_id,
 573      pgp => $pgp,
 574      pgpe => $pgpe,
 575      gpg => $gpg,
 576     );
 577
 578   my $recip = $self->{crypt_recipient} || $self->{to};
 579
 580   my $result = $encryptor->encrypt($recip, $content, %opts);
 581   unless ($result) {
 582     my $dump = $encryptor->can("dump") ? $encryptor->dump : "See error log";
 583     require BSE::TB::AuditLog;
 584     BSE::TB::AuditLog->log
 585         (
 586          %{$self->{log}},
 587          msg => "Error encrypting content: " . $encryptor->error,
 588          level => "crit",
 589          component => "composemail:done:encrypt",
 590          dump => $dump,
 591         );
 592     $self->{errstr} = "Error encrypting: " . $encryptor->error;
 593     return;
 594   }
 595
 596   if ($cfg->entry('shop', 'crypt_content_type', 0)) {
 597     $$rtype = 'application/pgp; format=text; x-action=encrypt';
 598   }
 599
 600   $result;
 601 }
 602
 603 sub errstr {
 604   $_[0]{errstr};
 605 }
 606
 607 sub tag_resource {
 608   my ($self, $args) = @_;
 609
 610   defined $args and $args =~ /^\w+$/
 611     or return "** invalid resource id $args **";
 612
 613   if ($self->{resource}{$args}) {
 614     return $self->{resource}{$args};
 615   }
 616
 617   my $res_entry = $self->{cfg}->entry('mail resources', $args)
 618     or return "** No resource $args found **";
 619   my ($filename, $type, $inline) = split /,/, $res_entry;
 620
 621   unless ($type) {
 622     if ($filename =~ /\.(gif|png|jpg)$/i) {
 623       $type = lc $1 eq 'jpg' ? 'image/jpeg' : 'image/' . lc $1;
 624     }
 625     else {
 626       $type = 'application/octet-stream';
 627     }
 628   }
 629   if (!defined $inline) {
 630     $inline = $type =~ m!^image/!;
 631   }
 632
 633   my $abs_filename = BSE::Template->find_source($filename, $self->{cfg})
 634     or return "** file $filename for resource $args not found **";
 635
 636   (my $display = $filename) =~ s/.*[\/\\]//;
 637
 638   my $url = $self->attach(file => $abs_filename,
 639                           display => $display,
 640                           type => $type,
 641                           inline => $inline)
 642     or return "** could not attach $args: $self->{errstr} **";
 643
 644   $self->{resource}{$args} = $url;
 645
 646   return $url;
 647 }
 648
 649 sub tag_set_subject {
 650   my ($self, $args, $acts, $tag, $templater) = @_;
 651
 652   my @args = DevHelp::Tags->get_parms($args, $acts, $templater);
 653
 654   $self->{subject} = "@args";
 655
 656   return '';
 657 }
 658
 659 sub send_simple {
 660   my ($class, %opts) = @_;
 661
 662   my $cfg = BSE::Cfg->single;
 663   my $mailer = $class->new(cfg => $cfg);
 664
 665   my $id = $opts{id}
 666     or confess "No mail id provided";
 667
 668   my $section = "email $id";
 669
 670   for my $key (qw/subject template html_template allow_html from from_name/) {
 671     my $value = $cfg->entry($section, $key);
 672     defined $value and $opts{$key} = $value;
 673   }
 674   unless (defined $opts{acts}) {
 675     require BSE::Util::Tags;
 676     BSE::Util::Tags->import(qw/tag_hash_plain/);
 677     my %acts =
 678       (
 679        BSE::Util::Tags->static(undef, $cfg),
 680       );
 681     if ($opts{extraacts}) {
 682       %acts = ( %acts, %{$opts{extraacts}} );
 683     }
 684     $opts{acts} = \%acts;
 685   }
 686
 687   $mailer->send(%opts)
 688     or print STDERR "Error sending mail $id: ", $mailer->errstr, "\n";
 689
 690   return 1;
 691 }
 692
 693
 694 1;