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