FS/FS/msg_template/email.pm

   1 package FS::msg_template::email;
   2 use base qw( FS::msg_template );
   3
   4 use strict;
   5 use vars qw( $DEBUG $conf );
   6
   7 # stuff needed for template generation
   8 use Date::Format qw( time2str );
   9 use File::Temp;
  10 use IPC::Run qw(run);
  11 use Text::Template;
  12
  13 use HTML::Entities qw( decode_entities encode_entities ) ;
  14 use HTML::FormatText;
  15 use HTML::TreeBuilder;
  16 use Encode;
  17
  18 # needed to send email
  19 use FS::Misc qw( generate_email );
  20 use FS::Conf;
  21 use Email::Sender::Simple qw( sendmail );
  22 use Email::Sender::Transport::SMTP;
  23
  24 use FS::Record qw( qsearch qsearchs );
  25
  26 # needed to manage template_content objects
  27 use FS::template_content;
  28 use FS::UID qw( dbh );
  29
  30 # needed to manage prepared messages
  31 use FS::cust_msg;
  32
  33 FS::UID->install_callback( sub { $conf = new FS::Conf; } );
  34
  35 our $DEBUG = 0;
  36 our $me = '[FS::msg_template::email]';
  37
  38 =head1 NAME
  39
  40 FS::msg_template::email - Construct email notices with Text::Template.
  41
  42 =head1 DESCRIPTION
  43
  44 FS::msg_template::email is a message processor in which the template contains
  45 L<Text::Template> strings for the message subject line and body, and the
  46 message is delivered by email.
  47
  48 Currently the C<from_addr> and C<bcc_addr> fields used by this processor are
  49 in the main msg_template table.
  50
  51 =head1 METHODS
  52
  53 =over 4
  54
  55 =item insert [ CONTENT ]
  56
  57 Adds this record to the database.  If there is an error, returns the error,
  58 otherwise returns false.
  59
  60 A default (no locale) L<FS::template_content> object will be created.  CONTENT
  61 is an optional hash containing 'subject' and 'body' for this object.
  62
  63 =cut
  64
  65 sub insert {
  66   my $self = shift;
  67   my %content = @_;
  68
  69   my $oldAutoCommit = $FS::UID::AutoCommit;
  70   local $FS::UID::AutoCommit = 0;
  71   my $dbh = dbh;
  72
  73   my $error = $self->SUPER::insert;
  74   if ( !$error ) {
  75     $content{'msgnum'} = $self->msgnum;
  76     $content{'subject'} ||= '';
  77     $content{'body'} ||= '';
  78     my $template_content = new FS::template_content (\%content);
  79     $error = $template_content->insert;
  80   }
  81
  82   if ( $error ) {
  83     $dbh->rollback if $oldAutoCommit;
  84     return $error;
  85   }
  86
  87   $dbh->commit if $oldAutoCommit;
  88   return;
  89 }
  90
  91 =item replace [ OLD_RECORD ] [ CONTENT ]
  92
  93 Replaces the OLD_RECORD with this one in the database.  If there is an error,
  94 returns the error, otherwise returns false.
  95
  96 CONTENT is an optional hash containing 'subject', 'body', and 'locale'.  If
  97 supplied, an L<FS::template_content> object will be created (or modified, if
  98 one already exists for this locale).
  99
 100 =cut
 101
 102 sub replace {
 103   my $self = shift;
 104   my $old = ( ref($_[0]) and $_[0]->isa('FS::Record') )
 105               ? shift
 106               : $self->replace_old;
 107   my %content = @_;
 108
 109   my $oldAutoCommit = $FS::UID::AutoCommit;
 110   local $FS::UID::AutoCommit = 0;
 111   my $dbh = dbh;
 112
 113   my $error = $self->SUPER::replace($old);
 114
 115   if ( !$error and %content ) {
 116     $content{'locale'} ||= '';
 117     my $new_content = qsearchs('template_content', {
 118                         'msgnum' => $self->msgnum,
 119                         'locale' => $content{'locale'},
 120                       } );
 121     if ( $new_content ) {
 122       $new_content->subject($content{'subject'});
 123       $new_content->body($content{'body'});
 124       $error = $new_content->replace;
 125     }
 126     else {
 127       $content{'msgnum'} = $self->msgnum;
 128       $new_content = new FS::template_content \%content;
 129       $error = $new_content->insert;
 130     }
 131   }
 132
 133   if ( $error ) {
 134     $dbh->rollback if $oldAutoCommit;
 135     return $error;
 136   }
 137
 138   warn "committing FS::msg_template->replace\n" if $DEBUG and $oldAutoCommit;
 139   $dbh->commit if $oldAutoCommit;
 140   return;
 141 }
 142
 143 =item content_locales
 144
 145 Returns a hashref of the L<FS::template_content> objects attached to
 146 this template, with the locale as key.
 147
 148 =cut
 149
 150 sub content_locales {
 151   my $self = shift;
 152   return $self->{'_content_locales'} ||= +{
 153     map { $_->locale , $_ }
 154     qsearch('template_content', { 'msgnum' => $self->msgnum })
 155   };
 156 }
 157
 158 =item prepare OPTION => VALUE
 159
 160 Fills in the template and returns an L<FS::cust_msg> object.
 161
 162 Options are passed as a list of name/value pairs:
 163
 164 =over 4
 165
 166 =item cust_main
 167
 168 Customer object
 169
 170 =item object
 171
 172 Additional context object (currently, can be a cust_main, cust_pkg,
 173 cust_bill, cust_pay, cust_pay_pending, or svc_(acct, phone, broadband,
 174 domain) ).  If the object is a svc_*, its cust_pkg will be fetched and
 175 used for substitution.
 176
 177 As a special case, this may be an arrayref of two objects.  Both
 178 objects will be available for substitution, with their field names
 179 prefixed with 'new_' and 'old_' respectively.  This is used in the
 180 rt_ticket export when exporting "replace" events.
 181
 182 =item from_config
 183
 184 Configuration option to use as the source address, based on the customer's
 185 agentnum.  If unspecified (or the named option is empty), 'invoice_from'
 186 will be used.
 187
 188 The I<from_addr> field in the template takes precedence over this.
 189
 190 =item to
 191
 192 Destination address.  The default is to use the customer's
 193 invoicing_list addresses.  Multiple addresses may be comma-separated.
 194
 195 =item substitutions
 196
 197 A hash reference of additional substitutions
 198
 199 =item msgtype
 200
 201 A string identifying the kind of message this is. Currently can be "invoice",
 202 "receipt", "admin", or null. Expand this list as necessary.
 203
 204 =item override_content
 205
 206 A string to use as the HTML body; if specified, replaces the entire
 207 body of the message. This should be used ONLY by L<FS::report_batch> and may
 208 go away in the future.
 209
 210 =item attach
 211
 212 A L<MIME::Entity> (or arrayref of them) to attach to the message.
 213
 214 =item to_contact_classnum
 215
 216 Set a string containing a comma-separated list.  This list may contain:
 217
 218 - the text "invoice" indicating contacts with invoice_dest flag should
 219   be included
 220 - the text "message" indicating contacts with message_dest flag should
 221   be included
 222 - numbers representing classnum id values for email contact classes.
 223   If any classnum are present, emails should only be sent to contact_email
 224   addresses where contact_email.classnum contains one of these classes.
 225   The classnum 0 also includes where contact_email.classnum IS NULL
 226
 227 If neither 'invoice' nor 'message' has been specified, this method will
 228 behave as if 'invoice' had been selected
 229
 230 =cut
 231
 232 =back
 233
 234 =cut
 235
 236 sub prepare {
 237
 238   my( $self, %opt ) = @_;
 239
 240   my $cust_main = $opt{'cust_main'}; # or die 'cust_main required';
 241   my $object = $opt{'object'}; # or die 'object required';
 242
 243   my $hashref = $self->prepare_substitutions(%opt);
 244
 245   # localization
 246   my $locale = $cust_main && $cust_main->locale || '';
 247   warn "no locale for cust#".$cust_main->custnum."; using default content\n"
 248     if $DEBUG and $cust_main && !$locale;
 249   my $content = $self->content($locale);
 250
 251   warn "preparing template '".$self->msgname."\n"
 252     if $DEBUG;
 253
 254   $_ = encode_entities($_ || '') foreach values(%$hashref);
 255
 256   ###
 257   # clean up template
 258   ###
 259   my $subject_tmpl = new Text::Template (
 260     TYPE   => 'STRING',
 261     SOURCE => $content->subject,
 262   );
 263
 264   warn "$me filling in subject template\n" if $DEBUG;
 265   my $subject = $subject_tmpl->fill_in( HASH => $hashref );
 266
 267   my $body = $content->body;
 268   my ($skin, $guts) = eviscerate($body);
 269   @$guts = map {
 270     $_ = decode_entities($_); # turn all punctuation back into itself
 271     s/\r//gs;           # remove \r's
 272     s/<br[^>]*>/\n/gsi; # and <br /> tags
 273     s/<p>/\n/gsi;       # and <p>
 274     s/<\/p>//gsi;       # and </p>
 275     s/\240/ /gs;        # and &nbsp;
 276     $_
 277   } @$guts;
 278
 279   $body = '{ use Date::Format qw(time2str); "" }';
 280   while(@$skin || @$guts) {
 281     $body .= shift(@$skin) || '';
 282     $body .= shift(@$guts) || '';
 283   }
 284
 285   ###
 286   # fill-in
 287   ###
 288
 289   my $body_tmpl = new Text::Template (
 290     TYPE          => 'STRING',
 291     SOURCE        => $body,
 292   );
 293
 294   warn "$me filling in body template\n" if $DEBUG;
 295   $body = $body_tmpl->fill_in( HASH => $hashref );
 296
 297   # override $body if requested
 298   if ( $opt{'override_content'} ) {
 299     warn "$me overriding template body with requested content" if $DEBUG;
 300     $body = $opt{'override_content'};
 301   }
 302
 303   ###
 304   # and email
 305   ###
 306
 307   my @to;
 308   if ( exists($opt{'to'}) ) {
 309
 310     @to = map { $_->format } Email::Address->parse($opt{'to'});
 311
 312   } elsif ( $cust_main ) {
 313
 314     my $classnum = $opt{'to_contact_classnum'} || '';
 315     my @classes = ref($classnum) ? @$classnum : split(',', $classnum);
 316
 317     # There are two e-mail opt-in flags per contact_email address.
 318     # If neither 'invoice' nor 'message' has been specified, default
 319     # to 'invoice'.
 320     #
 321     # This default supports the legacy behavior of
 322     #    send to all invoice recipients
 323     push @classes,'invoice'
 324       unless grep {$_ eq 'invoice' || $_ eq 'message'} @classes;
 325
 326     @to = $cust_main->contact_list_email(@classes);
 327     # not guaranteed to produce contacts, but then customers aren't
 328     # guaranteed to have email addresses on file. in that case, env_to
 329     # will be null and sending this message will fail.
 330
 331   } else {
 332     die 'no To: address or cust_main object specified';
 333   }
 334
 335   my $from_addr = $self->from_addr;
 336
 337   if ( !$from_addr ) {
 338
 339     my $agentnum = $cust_main ? $cust_main->agentnum : '';
 340
 341     if ( $opt{'from_config'} ) {
 342       $from_addr = $conf->config($opt{'from_config'}, $agentnum);
 343     }
 344     $from_addr ||= $conf->invoice_from_full($agentnum);
 345   }
 346
 347   my $text_body = encode('UTF-8',
 348                   HTML::FormatText->new(leftmargin => 0, rightmargin => 70)
 349                       ->format( HTML::TreeBuilder->new_from_content($body) )
 350                   );
 351
 352   warn "$me constructing MIME entities\n" if $DEBUG;
 353   my %email = generate_email(
 354     'from'      => $from_addr,
 355     'to'        => \@to,
 356     'bcc'       => $self->bcc_addr || undef,
 357     'subject'   => $subject,
 358     'html_body' => $body,
 359     'text_body' => $text_body,
 360   );
 361
 362   warn "$me creating message headers\n" if $DEBUG;
 363   # strip display-name from envelope addresses
 364   # (use Email::Address for this? it chokes on non-ASCII characters in
 365   # the display-name, which is not great for us)
 366   my $env_from = $from_addr;
 367   foreach ($env_from, @to) {
 368     s/^\s*//;
 369     s/\s*$//;
 370     s/^(.*)\s*<(.*@.*)>$/$2/;
 371   }
 372
 373   my $domain;
 374   if ( $env_from =~ /\@([\w\.\-]+)/ ) {
 375     $domain = $1;
 376   } else {
 377     warn 'no domain found in invoice from address '. $env_from .
 378          '; constructing Message-ID (and saying HELO) @example.com';
 379     $domain = 'example.com';
 380   }
 381   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 382
 383   my $time = time;
 384   my $message = MIME::Entity->build(
 385     'From'        => $from_addr,
 386     'To'          => join(', ', @to),
 387     'Sender'      => $from_addr,
 388     'Reply-To'    => $from_addr,
 389     'Date'        => time2str("%a, %d %b %Y %X %z", $time),
 390     'Subject'     => Encode::encode('MIME-Header', $subject),
 391     'Message-ID'  => "<$message_id>",
 392     'Encoding'    => '7bit',
 393     'Type'        => 'multipart/related',
 394   );
 395
 396   if ( $opt{'attach'} ) {
 397     my @attach;
 398     if (ref $opt{'attach'} eq 'ARRAY') {
 399       @attach = @{ $opt{'attach'} };
 400     } else {
 401       @attach = $opt{'attach'};
 402     }
 403     foreach (@attach) {
 404       $message->add_part($_);
 405     }
 406   }
 407
 408   #$message->head->replace('Content-type',
 409   #  'multipart/related; '.
 410   #  'boundary="' . $message->head->multipart_boundary . '"; ' .
 411   #  'type=multipart/alternative'
 412   #);
 413
 414   foreach my $part (@{ $email{mimeparts} }) {
 415     warn "$me appending part ".$part->mime_type."\n" if $DEBUG;
 416     $message->add_part( $part );
 417   }
 418
 419   # effective To: address (not in headers)
 420   push @to, $self->bcc_addr if $self->bcc_addr;
 421   my @env_to;
 422   foreach my $dest (@to) {
 423     push @env_to, map { $_->address } Email::Address->parse($dest);
 424   }
 425
 426   my $cust_msg = FS::cust_msg->new({
 427       'custnum'   => $cust_main ? $cust_main->custnum : '',
 428       'msgnum'    => $self->msgnum,
 429       '_date'     => $time,
 430       'env_from'  => $env_from,
 431       'env_to'    => join(',', @env_to),
 432       'header'    => $message->header_as_string,
 433       'body'      => $message->body_as_string,
 434       'error'     => '',
 435       'status'    => 'prepared',
 436       'msgtype'   => ($opt{'msgtype'} || ''),
 437       'preview'   => $body, # html content only
 438   });
 439
 440   return $cust_msg;
 441 }
 442
 443 =item render OPTION => VALUE ...
 444
 445 Fills in the template and renders it to a PDF document.  Returns the
 446 name of the PDF file.
 447
 448 Options are as for 'prepare', but 'from' and 'to' are meaningless.
 449
 450 =cut
 451
 452 # will also have options to set paper size, margins, etc.
 453
 454 sub render {
 455   my $self = shift;
 456   eval "use PDF::WebKit";
 457   die $@ if $@;
 458   my %opt = @_;
 459   my %hash = $self->prepare(%opt);
 460   my $html = $hash{'html_body'};
 461
 462   # Graphics/stylesheets should probably go in /var/www on the Freeside
 463   # machine.
 464   my $script_path = `/usr/bin/which freeside-wkhtmltopdf`;
 465   chomp $script_path;
 466   my $kit = PDF::WebKit->new(\$html); #%options
 467   # hack to use our wrapper script
 468   $kit->configure(sub { shift->wkhtmltopdf($script_path) });
 469
 470   $kit->to_pdf;
 471 }
 472
 473 =item print OPTIONS
 474
 475 Render a PDF and send it to the printer.  OPTIONS are as for 'render'.
 476
 477 =cut
 478
 479 sub print {
 480   my( $self, %opt ) = @_;
 481   do_print( [ $self->render(%opt) ], agentnum=>$opt{cust_main}->agentnum );
 482 }
 483
 484 # helper sub for package dates
 485 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
 486
 487 # helper sub for money amounts
 488 my $money = sub { ($conf->money_char || '$') . sprintf('%.2f', $_[0] || 0) };
 489
 490 # helper sub for usage-related messages
 491 my $usage_warning = sub {
 492   my $svc = shift;
 493   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
 494     my $amount = $svc->$col; next if $amount eq '';
 495     my $method = $col.'_threshold';
 496     my $threshold = $svc->$method; next if $threshold eq '';
 497     return [$col, $amount, $threshold] if $amount <= $threshold;
 498     # this only returns the first one that's below threshold, if there are
 499     # several.
 500   }
 501   return ['', '', ''];
 502 };
 503
 504 =item content LOCALE
 505
 506 Returns the L<FS::template_content> object appropriate to LOCALE, if there
 507 is one.  If not, returns the one with a NULL locale.
 508
 509 =cut
 510
 511 sub content {
 512   my $self = shift;
 513   my $locale = shift;
 514   qsearchs('template_content',
 515             { 'msgnum' => $self->msgnum, 'locale' => $locale }) ||
 516   qsearchs('template_content',
 517             { 'msgnum' => $self->msgnum, 'locale' => '' });
 518 }
 519
 520 =cut
 521
 522 =item send_prepared CUST_MSG
 523
 524 Takes the CUST_MSG object and sends it to its recipient. The "smtpmachine"
 525 configuration option will be used to find the outgoing mail server.
 526
 527 =cut
 528
 529 sub send_prepared {
 530   my $self = shift;
 531   my $cust_msg = shift or die "cust_msg required";
 532
 533   if ( $FS::Misc::DISABLE_ALL_NOTICES ) {
 534     warn 'send_prepared() disabled by $FS::Misc::DISABLE_ALL_NOTICES' if $DEBUG;
 535     return;
 536   }
 537
 538   my $domain = 'example.com';
 539   if ( $cust_msg->env_from =~ /\@([\w\.\-]+)/ ) {
 540     $domain = $1;
 541   }
 542
 543   # in principle should already be a list of bare addresses, but run it
 544   # through Email::Address to make sure
 545   my @env_to = map { $_->address } Email::Address->parse($cust_msg->env_to);
 546
 547   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
 548                    'helo' => $domain );
 549
 550   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
 551   $smtp_opt{'port'} = $port;
 552
 553   if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
 554     $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
 555   } elsif ( defined($enc) && $enc eq 'starttls') {
 556     $error = "SMTP settings misconfiguration: STARTTLS enabled in ".
 557             "smtp-encryption but smtp-username or smtp-password missing";
 558   }
 559
 560   if ( defined($enc) ) {
 561     $smtp_opt{'ssl'} = 'starttls' if $enc eq 'starttls';
 562     $smtp_opt{'ssl'} = 1          if $enc eq 'tls';
 563   }
 564
 565   my $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
 566
 567   warn "$me sending message\n" if $DEBUG;
 568   my $message = join("\n", $cust_msg->header, $cust_msg->body);
 569   local $@;
 570   eval {
 571     sendmail( $message, { transport => $transport,
 572                           from      => $cust_msg->env_from,
 573                           to        => \@env_to })
 574   };
 575   my $error = '';
 576   if(ref($@) and $@->isa('Email::Sender::Failure')) {
 577     $error = $@->code.' ' if $@->code;
 578     $error .= $@->message;
 579   }
 580   else {
 581     $error = $@;
 582   }
 583
 584   $cust_msg->set('error', $error);
 585   $cust_msg->set('status', $error ? 'failed' : 'sent');
 586   if ( $cust_msg->custmsgnum ) {
 587     $cust_msg->replace;
 588   } else {
 589     $cust_msg->insert;
 590   }
 591
 592   $error;
 593 }
 594
 595 =back
 596
 597 =cut
 598
 599 # internal use only
 600
 601 sub eviscerate {
 602   # Every bit as pleasant as it sounds.
 603   #
 604   # We do this because Text::Template::Preprocess doesn't
 605   # actually work.  It runs the entire template through
 606   # the preprocessor, instead of the code segments.  Which
 607   # is a shame, because Text::Template already contains
 608   # the code to do this operation.
 609   my $body = shift;
 610   my (@outside, @inside);
 611   my $depth = 0;
 612   my $chunk = '';
 613   while($body || $chunk) {
 614     my ($first, $delim, $rest);
 615     # put all leading non-delimiters into $first
 616     ($first, $rest) =
 617         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
 618     $chunk .= $first;
 619     # put a leading delimiter into $delim if there is one
 620     ($delim, $rest) =
 621       ($rest =~ /^([{}]?)(.*)$/s);
 622
 623     if( $delim eq '{' ) {
 624       $chunk .= '{';
 625       if( $depth == 0 ) {
 626         push @outside, $chunk;
 627         $chunk = '';
 628       }
 629       $depth++;
 630     }
 631     elsif( $delim eq '}' ) {
 632       $depth--;
 633       if( $depth == 0 ) {
 634         push @inside, $chunk;
 635         $chunk = '';
 636       }
 637       $chunk .= '}';
 638     }
 639     else {
 640       # no more delimiters
 641       if( $depth == 0 ) {
 642         push @outside, $chunk . $rest;
 643       } # else ? something wrong
 644       last;
 645     }
 646     $body = $rest;
 647   }
 648   (\@outside, \@inside);
 649 }
 650
 651 =head1 BUGS
 652
 653 =head1 SEE ALSO
 654
 655 L<FS::Record>, schema.html from the base documentation.
 656
 657 =cut
 658
 659 1;