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 = split(/\s*,\s*/, $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 = join(', ', @to);
 397
 398   my $cust_msg = FS::cust_msg->new({
 399       'custnum'   => $cust_main ? $cust_main->custnum : '',
 400       'msgnum'    => $self->msgnum,
 401       '_date'     => $time,
 402       'env_from'  => $env_from,
 403       'env_to'    => $env_to,
 404       'header'    => $message->header_as_string,
 405       'body'      => $message->body_as_string,
 406       'error'     => '',
 407       'status'    => 'prepared',
 408       'msgtype'   => ($opt{'msgtype'} || ''),
 409       'preview'   => $body, # html content only
 410   });
 411
 412   return $cust_msg;
 413 }
 414
 415 =item render OPTION => VALUE ...
 416
 417 Fills in the template and renders it to a PDF document.  Returns the
 418 name of the PDF file.
 419
 420 Options are as for 'prepare', but 'from' and 'to' are meaningless.
 421
 422 =cut
 423
 424 # will also have options to set paper size, margins, etc.
 425
 426 sub render {
 427   my $self = shift;
 428   eval "use PDF::WebKit";
 429   die $@ if $@;
 430   my %opt = @_;
 431   my %hash = $self->prepare(%opt);
 432   my $html = $hash{'html_body'};
 433
 434   # Graphics/stylesheets should probably go in /var/www on the Freeside
 435   # machine.
 436   my $script_path = `/usr/bin/which freeside-wkhtmltopdf`;
 437   chomp $script_path;
 438   my $kit = PDF::WebKit->new(\$html); #%options
 439   # hack to use our wrapper script
 440   $kit->configure(sub { shift->wkhtmltopdf($script_path) });
 441
 442   $kit->to_pdf;
 443 }
 444
 445 =item print OPTIONS
 446
 447 Render a PDF and send it to the printer.  OPTIONS are as for 'render'.
 448
 449 =cut
 450
 451 sub print {
 452   my( $self, %opt ) = @_;
 453   do_print( [ $self->render(%opt) ], agentnum=>$opt{cust_main}->agentnum );
 454 }
 455
 456 # helper sub for package dates
 457 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
 458
 459 # helper sub for money amounts
 460 my $money = sub { ($conf->money_char || '$') . sprintf('%.2f', $_[0] || 0) };
 461
 462 # helper sub for usage-related messages
 463 my $usage_warning = sub {
 464   my $svc = shift;
 465   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
 466     my $amount = $svc->$col; next if $amount eq '';
 467     my $method = $col.'_threshold';
 468     my $threshold = $svc->$method; next if $threshold eq '';
 469     return [$col, $amount, $threshold] if $amount <= $threshold;
 470     # this only returns the first one that's below threshold, if there are
 471     # several.
 472   }
 473   return ['', '', ''];
 474 };
 475
 476 =item content LOCALE
 477
 478 Returns the L<FS::template_content> object appropriate to LOCALE, if there
 479 is one.  If not, returns the one with a NULL locale.
 480
 481 =cut
 482
 483 sub content {
 484   my $self = shift;
 485   my $locale = shift;
 486   qsearchs('template_content',
 487             { 'msgnum' => $self->msgnum, 'locale' => $locale }) ||
 488   qsearchs('template_content',
 489             { 'msgnum' => $self->msgnum, 'locale' => '' });
 490 }
 491
 492 =cut
 493
 494 =item send_prepared CUST_MSG
 495
 496 Takes the CUST_MSG object and sends it to its recipient. The "smtpmachine"
 497 configuration option will be used to find the outgoing mail server.
 498
 499 =cut
 500
 501 sub send_prepared {
 502   my $self = shift;
 503   my $cust_msg = shift or die "cust_msg required";
 504
 505   my $domain = 'example.com';
 506   if ( $cust_msg->env_from =~ /\@([\w\.\-]+)/ ) {
 507     $domain = $1;
 508   }
 509
 510   my @to = split(/\s*,\s*/, $cust_msg->env_to);
 511
 512   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
 513                    'helo' => $domain );
 514
 515   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
 516   $smtp_opt{'port'} = $port;
 517
 518   my $transport;
 519   if ( defined($enc) && $enc eq 'starttls' ) {
 520     $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
 521     $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
 522   } else {
 523     if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
 524       $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
 525     }
 526     $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
 527     $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
 528   }
 529
 530   warn "$me sending message\n" if $DEBUG;
 531   my $message = join("\n", $cust_msg->header, $cust_msg->body);
 532   local $@;
 533   eval {
 534     sendmail( $message, { transport => $transport,
 535                           from      => $cust_msg->env_from,
 536                           to        => \@to })
 537   };
 538   my $error = '';
 539   if(ref($@) and $@->isa('Email::Sender::Failure')) {
 540     $error = $@->code.' ' if $@->code;
 541     $error .= $@->message;
 542   }
 543   else {
 544     $error = $@;
 545   }
 546
 547   $cust_msg->set('error', $error);
 548   $cust_msg->set('status', $error ? 'failed' : 'sent');
 549   if ( $cust_msg->custmsgnum ) {
 550     $cust_msg->replace;
 551   } else {
 552     $cust_msg->insert;
 553   }
 554
 555   $error;
 556 }
 557
 558 =back
 559
 560 =cut
 561
 562 # internal use only
 563
 564 sub eviscerate {
 565   # Every bit as pleasant as it sounds.
 566   #
 567   # We do this because Text::Template::Preprocess doesn't
 568   # actually work.  It runs the entire template through
 569   # the preprocessor, instead of the code segments.  Which
 570   # is a shame, because Text::Template already contains
 571   # the code to do this operation.
 572   my $body = shift;
 573   my (@outside, @inside);
 574   my $depth = 0;
 575   my $chunk = '';
 576   while($body || $chunk) {
 577     my ($first, $delim, $rest);
 578     # put all leading non-delimiters into $first
 579     ($first, $rest) =
 580         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
 581     $chunk .= $first;
 582     # put a leading delimiter into $delim if there is one
 583     ($delim, $rest) =
 584       ($rest =~ /^([{}]?)(.*)$/s);
 585
 586     if( $delim eq '{' ) {
 587       $chunk .= '{';
 588       if( $depth == 0 ) {
 589         push @outside, $chunk;
 590         $chunk = '';
 591       }
 592       $depth++;
 593     }
 594     elsif( $delim eq '}' ) {
 595       $depth--;
 596       if( $depth == 0 ) {
 597         push @inside, $chunk;
 598         $chunk = '';
 599       }
 600       $chunk .= '}';
 601     }
 602     else {
 603       # no more delimiters
 604       if( $depth == 0 ) {
 605         push @outside, $chunk . $rest;
 606       } # else ? something wrong
 607       last;
 608     }
 609     $body = $rest;
 610   }
 611   (\@outside, \@inside);
 612 }
 613
 614 =head1 BUGS
 615
 616 =head1 SEE ALSO
 617
 618 L<FS::Record>, schema.html from the base documentation.
 619
 620 =cut
 621
 622 1;
 623