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